perm filename COMPLR[MLI,LSP] blob
sn#111756 filedate 1975-06-03 generic text, type T, neo UTF8
00100 (PROG (SEXPR IBASE)
00200 (SETQ IBASE (ADD1 7))
00300 LOOP (SETQ SEXPR (ERRSET (READ)))
00400 (COND ((EQ SEXPR (QUOTE $EOF$)) (RETURN NIL)))
00500 (COND ((MEMQ (CAAR SEXPR) (QUOTE (BEGINBLOCK ENDBLOCK)))
00600 (GO LOOP)))
00700 (PRINT (EVAL (CAR SEXPR)))
00800 (GO LOOP))
00900
01000 (BEGINBLOCK COMPILER)
01100
01200 (DECLARE (SPECIAL LASTOUT LOCVARS SPECVARS P1CNT P2CNT FUNNAME)
01300 (SPECIAL ALLVARS RENAMELIST INPROG P1SCNT P1SCV FOUNDFREE)
01400 (SPECIAL LISTING MSGCHAN INDEV OUTDEV OUTEXT)
01500 (SPECIAL ACS PDL PDLDEPTH MINDEPTH)
01600 (SPECIAL LDLST PRGSPFLG PROGVARS SPLDLST CCLST RSL CTAG)
01700 (SPECIAL PROGSW GOLIST VARLIST)
01800 (SPECIAL GOLIST EXIT EXITN PRSSL PROGSW VGO PVR)
01900 (SPECIAL NACS VALUEAC ALLACS GOTABAC FARGAC ARRAYAC)
02000 (SPECIAL ALLFUNS GENFUNS UNDFUNS CODESIZE CONSTSIZE)
02100 (SPECIAL LINCNT PAGEWIDTH PAGEHEIGHT)
02200 (SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT)
02300 (SPECIAL *LP *RP *SL *AM *AT *RO *COLON)
02400 (SPECIAL IBASE BASE *NOPOINT INUM0)
02500 (SPECIAL TRACELIST SHOWNAMES))
02600
02700 (BEGINBLOCK MACROS)
02800
02900 (DEFPROP DEINITTAG (LAMBDA (L) (QUOTE (DEINITSYM (QUOTE TAG)))) MACRO)
03000
03100 (DEFPROP DEINITVAL (LAMBDA (L) (QUOTE (DEINITSYM (QUOTE VAL)))) MACRO)
03200
03300 (DEFPROP DEINITVAR (LAMBDA (L) (QUOTE (DEINITSYM (QUOTE VAR)))) MACRO)
03400
03500 (DEFPROP DFUNC
03600 (LAMBDA (L)
03700 (LIST (QUOTE DEFPROP)
03800 (CAADR L)
03900 (MCONS (QUOTE LAMBDA) (CDADR L) (CDDR L))
04000 (QUOTE EXPR)))
04100 MACRO)
04200
04300 (DEFPROP FLUSHDEF (LAMBDA (L) (CONS (QUOTE FLUSHEXPR) (CDR L))) MACRO)
04400
04500 (DEFPROP GENTAG (LAMBDA (L) (QUOTE (NEXTSYM (QUOTE TAG)))) MACRO)
04600
04700 (DEFPROP GENVAL (LAMBDA (L) (QUOTE (NEXTSYM (QUOTE VAL)))) MACRO)
04800
04900 (DEFPROP GENVAR (LAMBDA (L) (QUOTE (NEXTSYM (QUOTE VAR)))) MACRO)
05000
05100 (DEFPROP GETPROP (LAMBDA (L) (CONS (QUOTE GET) (CDR L))) MACRO)
05200
00100 (DEFPROP IFIF
00200 (LAMBDA (L)
00300 (LIST (QUOTE COND) (CDR L) (LIST T (CONS (QUOTE NOT) (CDDR L)))))
00400 MACRO)
00500
00600 (DEFPROP INCR
00700 (LAMBDA (L)
00800 (LIST (QUOTE SETQ) (CADR L) (LIST (QUOTE ADD1) (CADR L))))
00900 MACRO)
01000
01100 (DEFPROP INITTAG (LAMBDA (L) (QUOTE (INITSYM (QUOTE TAG)))) MACRO)
01200
01300 (DEFPROP INITVAL (LAMBDA (L) (QUOTE (INITSYM (QUOTE VAL)))) MACRO)
01400
01500 (DEFPROP INITVAR (LAMBDA (L) (QUOTE (INITSYM (QUOTE VAR)))) MACRO)
01600
01700 (DEFPROP MAPDEF
01800 (LAMBDA (L)
01900 (LIST (QUOTE MAPCAR)
02000 (SUBST (CADR L)
02100 (QUOTE IND)
02200 (QUOTE (FUNCTION (LAMBDA (PAIR)
02300 (PUTPROP (CAR PAIR)
02400 (CADR PAIR)
02500 (QUOTE IND))))))
02600 (LIST (QUOTE QUOTE) (CDDR L))))
02700 MACRO)
02800
02900 (DEFPROP MCONS
03000 (LAMBDA (L)
03100 (COND ((NULL (CDDR L)) (CADR L))
03200 (T (LIST (QUOTE CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
03300 MACRO)
03400
03500 (DEFPROP OUTINST (LAMBDA (INST) (CONS (QUOTE OUTSTAT) (CDR INST))) MACRO)
03600
03700 (DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (QUOTE OUTSTAT) (CDR PSOP))) MACRO)
03800
03900 (DEFPROP OUTTAG (LAMBDA (TAG) (CONS (QUOTE OUTSTAT) (CDR TAG))) MACRO)
04000
04100 (DEFPROP PDLDEPTH (LAMBDA (L) (QUOTE PDLDEPTH)) MACRO)
04200
04300 (DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
04400
04500 (DEFPROP TAGP (LAMBDA (L) (CONS (QUOTE ATOM) (CDR L))) MACRO)
04600
00100 (DEFPROP USERWARN
00200 (LAMBDA (L)
00300 (LIST (QUOTE PRINTMSG)
00400 (LIST (QUOTE APPEND)
00500 (LIST (QUOTE LIST) (CADR L))
00600 (LIST (QUOTE QUOTE) (APPEND (CDDR L) (QUOTE (IN))))
00700 (QUOTE (LIST (CURFUN))))))
00800 MACRO)
00900
01000 (BEGINBLOCK PROPTABLE)
01100
01200 (DEFPROP FIRSTPROP (LAMBDA (L) (CONS (QUOTE CDR) (CDR L))) MACRO)
01300
01400 (DEFPROP LASTPROP (LAMBDA (L) (CONS (QUOTE NULL) (CDR L))) MACRO)
01500
01600 (DEFPROP NEXTPROP (LAMBDA (L) (CONS (QUOTE CDDR) (CDR L))) MACRO)
01700
01800 (DEFPROP PROPNAM (LAMBDA (L) (CONS (QUOTE CAR) (CDR L))) MACRO)
01900
02000 (DEFPROP PROPTABLE (LAMBDA (L) (CONS (QUOTE CDR) (CDR L))) MACRO)
02100
02200 (DEFPROP PROPVAL (LAMBDA (L) (CONS (QUOTE CADR) (CDR L))) MACRO)
02300
02400 (ENDBLOCK PROPTABLE)
02500
02600 (ENDBLOCK MACROS)
02700
02800 (BEGINBLOCK TOPLEVEL)
02900
03000 (DFUNC (ACTONEXPR XPR)
03100 (PROG (ACTION)
03200 (COND ((ATOM XPR) (GO FLUSH)))
03300 (SETQ ACTION (GETGET (CAR XPR) (QUOTE COMPEFFECT)))
03400 (COND (ACTION ((CADR ACTION) XPR) (RETURN NIL)))
03500 FLUSH(FLUSHEXPR XPR)
03600 (RETURN NIL)))
03700
03800 (DFUNC (ACTONMACRO XPR)
03900 (ACTONEXPR ((GETPROP (CAR XPR) (QUOTE MACRO)) XPR)))
04000
04100 (DEFPROP CMP
04200 (LAMBDA (L)
04300 (COND ((NULL L) NIL)
04400 ((NULL (CDR L)) (COMPILEFUN (CAR L)))
04500 (T (PUTPROP (CAAR L)
04600 (MCONS (QUOTE LAMBDA) (CDAR L) (CDR L))
04700 (COND ((NULL (CDDR L)) (QUOTE EXPR)) (T (CADDR L))))
04800 (COMPILEFUN (CAAR L)))))
04900 FEXPR)
05000
00100 (DFUNC (COMPDEF DEFIN)
00200 (PROG (ACTION)
00300 (COND ((NOT (EQUAL (LENGTH DEFIN) 4))
00400 (USERERR ARGNOERR-COMPDEF)))
00500 (COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (QUOTE DEFACTION)))
00600 ((CADR ACTION) DEFIN)
00700 (RETURN NIL)))
00800 (FLUSHDEF DEFIN)
00900 (RETURN NIL)))
01000
01100 (DFUNC (COMPFILE INFILE OUTFILE)
01200 (PROG (ALLFUNS UNDFUNS GENFUNS CODESIZE CONSTSIZE STARTTIME)
01300 (INITPROP (QUOTE CURFILE) (QUOTE NAME) INFILE)
01400 (SETQ STARTTIME (TIME))
01500 (SETQ CODESIZE (SETQ CONSTSIZE 0))
01600 (DOFILE (FUNCTION COMPREADS) INFILE OUTFILE)
01700 (TELLTALE (CADR INFILE) STARTTIME)
01800 (DELETEPROP (QUOTE CURFILE) (QUOTE NAME))))
01900
02000 (DFUNC (COMPFUNC NAME EXPR FLAG)
02100 (PROG (LOCVARS SPECVARS P1EXP P1CNT P2CNT LASTOUT)
02200 (INITTAG)
02300 (INITVAL)
02400 (INITVAR)
02500 (INITPROP (QUOTE CURFUN) (QUOTE NAME) NAME)
02600 (INITPROP (QUOTE SUBFUN) (QUOTE SYMNO) 1)
02700 (SETQ P1EXP (PASS1 EXPR))
02800 (DELETEPROP (QUOTE SUBFUN) (QUOTE SYMNO))
02900 (COND ((NOT (ATMARGIN)) (LINEF 2)))
03000 (OUTPSOP (LIST (QUOTE LAP) NAME FLAG))
03100 (COND ((EQ (CAR EXPR) (QUOTE FSUBR))
03200 (COND ((NOT (NULL (CDADR EXPR)))
03300 (OUTINST (QUOTE (PUSHJ P *AMAKE))))))
03400 ((EQ (CAR EXPR) (QUOTE LSUBR))
03500 (OUTINST (QUOTE (JSP 3 *LCALL)))
03600 (INITPROP (QUOTE ARG) (QUOTE P2) (QUOTE P2ARG))))
03700 (PASS2 P1EXP)
03800 (DELETEPROP (QUOTE CURFUN) (QUOTE NAME))
03900 (COND ((EQ (CAR EXPR) (QUOTE LSUBR)) (DELETEPROP (QUOTE ARG) (QUOTE P2))))
04000 (COND ((NOT (EQUAL P2CNT P1CNT))
04100 (PRINTMSG (LIST P1CNT P2CNT))
04200 (COMPERR COUNTSDISAGREE-COMPFUNC)))
04300 (DEINITTAG)
04400 (DEINITVAL)
04500 (DEINITVAR)
04600 (RETURN NAME)))
04700
00100 (DEFPROP COMPILE
00200 (LAMBDA (NAMES)
00300 (PROG (DONE)
00400 LOOP (COND ((NULL NAMES) (OUTC NIL T) (RETURN DONE)))
00500 (COND ((NOT (ATOM (CAR NAMES)))
00600 (OUTC (EVAL (CONS (QUOTE OUTPUT) (CAR NAMES))) NIL))
00700 (T (SETQ DONE (APPEND DONE (COMPILEFUN (CAR NAMES))))))
00800 (SETQ NAMES (CDR NAMES))
00900 (GO LOOP)))
01000 FEXPR)
01100
01200 (DFUNC (COMPILEFUN NAME)
01300 (PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE MSGCHAN SHOWNAMES PROP
01400 DONE PLIST)
01500 (SETQ CODESIZE (SETQ CONSTSIZE 0))
01600 (SETQ PLIST (CDR NAME))
01700 LOOP (COND ((NULL PLIST) (RETURN (REVERSE DONE))))
01800 (SETQ PROP (SEEKPROP (CAR PLIST) (QUOTE DEFACTION)))
01900 (COND ((NULL PROP) (GO ELOOP)))
02000 (SETQ DONE (CONS (CONS NAME (CAR PLIST)) DONE))
02100 ((CADR PROP)
02200 (LIST (QUOTE DEFPROP) NAME (CADR PLIST) (CAR PLIST)))
02300 ELOOP(SETQ PLIST (CDDR PLIST))
02400 (GO LOOP)))
02500
02600 (DEFPROP COMPL
02700 (LAMBDA (FILES)
02800 (PROG (MSGCHAN)
02900 (COND ((NOT (NULL LISTING))
03000 (SETQ MSGCHAN (EVAL (MCONS (QUOTE OUTPUT)
03100 (GENSYM)
03200 LISTING)))))
03300 LOOP (COND ((NULL FILES) (OUTC MSGCHAN NIL)
03400 (OUTC NIL T)
03500 (RETURN NIL)))
03600 (COND ((OR (EQ (CAR (LAST (EXPLODE (CAR FILES)))) *COLON)
03700 (AND (NOT (ATOM (CAR FILES)))
03800 (NOT (ATOM (CDAR FILES)))))
03900 (SETQ INDEV (CAR FILES))
04000 (GO ELOOP)))
04100 (COMPFILE (LIST INDEV (CAR FILES))
04200 (LIST OUTDEV
04300 (CONS (COND ((ATOM (CAR FILES)) (CAR FILES))
04400 (T (CAAR FILES)))
04500 OUTEXT)))
04600 ELOOP(SETQ FILES (CDR FILES))
04700 (GO LOOP)))
04800 FEXPR)
04900
05000 (DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR)))
05100
00100 (DFUNC (CURFILE) (GETPROP (QUOTE CURFILE) (QUOTE NAME)))
00200
00300 (DFUNC (CURFUN) (GETPROP (QUOTE CURFUN) (QUOTE NAME)))
00400
00500 (DEFPROP DECLARE (LAMBDA (L) (MAPC (FUNCTION EVAL) L)) FEXPR)
00600
00700 (DFUNC (DEFEXPR DEF)
00800 (PROG (FN EX)
00900 (SETQ FN (CADR DEF))
01000 (SETQ EX (CADDR DEF))
01100 (COND ((OR (ATOM EX) (NOT (EQ (CAR EX) (QUOTE LAMBDA))))
01200 (FLUSHDEF DEF))
01300 ((AND (ATOM (CADR EX)) (NOT (NULL (CADR EX))))
01400 (COND ((REMPROP FN (QUOTE *UNDEF))
01500 (PRINTMSG (CONS FN (QUOTE (LSUBR USED AS SUBR))))))
01600 (PUTPROP FN T (QUOTE *LSUBR))
01700 (COMPFUNC FN
01800 (MCONS (QUOTE LSUBR) (LIST (CADR EX)) (CDDR EX))
01900 (QUOTE LSUBR)))
02000 (T (REMPROP FN (QUOTE *UNDEF))
02100 (PUTPROP FN T (QUOTE *SUBR))
02200 (COMPFUNC FN (CONS (QUOTE SUBR) (CDR EX)) (QUOTE SUBR))))
02300 (TYPEFN FN)))
02400
02500 (DFUNC (DEFFEXPR DEF)
02600 (PROG (FN EX)
02700 (SETQ FN (CADR DEF))
02800 (SETQ EX (CADDR DEF))
02900 (COND ((REMPROP FN (QUOTE *UNDEF))
03000 (PRINTMSG (CONS FN (QUOTE (FSUBR USED AS SUBR))))))
03100 (PUTPROP FN T (QUOTE *FSUBR))
03200 (COMPFUNC FN (CONS (QUOTE FSUBR) (CDR EX)) (QUOTE FSUBR))
03300 (TYPEFN FN)))
03400
03500 (DFUNC (DEFMACRO DEF)
03600 (PROG NIL
03700 (COND ((REMPROP (CADR DEF) (QUOTE *UNDEF))
03800 (PRINTMSG (CONS (CADR DEF) (QUOTE (MACRO USED AS SUBR))))))
03900 (PUTPROP (CADR DEF) (CADDR DEF) (QUOTE MACRO))
04000 (TYPEFN (CADR DEF))))
04100
04200 (DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (QUOTE *SUBR)))
04300
04400 (DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (QUOTE *FSUBR)))
04500
04600 (DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (QUOTE COMPACTION)) XPR))
04700
04800 (DFUNC (DODE L)
04900 (DEFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (QUOTE EXPR))))
05000
00100 (DFUNC (DODF L)
00200 (DEFFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (QUOTE FEXPR))))
00300
00400 (DFUNC (DODM L)
00500 (DEFMACRO (MAKDEF (CADR L) (CADDR L) (CADDDR L) (QUOTE MACRO))))
00600
00700 (DFUNC (DOFILE DOREADS INFILE OUTFILE)
00800 (PROG (LINCNT)
00900 (SETQ LINCNT 0)
01000 (EVAL (MCONS (QUOTE INPUT) (QUOTE INCHAN) INFILE))
01100 (EVAL (MCONS (QUOTE OUTPUT) (QUOTE OUTCHAN) OUTFILE))
01200 (INC (QUOTE INCHAN) NIL)
01300 (OUTC (QUOTE OUTCHAN) NIL)
01400 (DOREADS)
01500 (OUTC NIL T)
01600 (INC NIL T)))
01700
01800 (DFUNC (FLUSHEXPR EXPR)
01900 (PROG2 (COND ((NOT (ATMARGIN)) (LINEF 2))) (PRINTEXPR EXPR)))
02000
02100 (DFUNC (FLUSHLAP ENTRY)
02200 (PROG (NAME FLAG TYPE STAT)
02300 (SETQ NAME (CADR ENTRY))
02400 (SETQ FLAG (CADDR ENTRY))
02500 (SETQ TYPE (ASSOC FLAG
02600 (QUOTE ((FSUBR *FSUBR) (LSUBR *LSUBR)
02700 (SUBR *SUBR)))))
02800 (COND ((NULL TYPE) (GO PRINT)))
02900 (SETQ TYPE (CADR TYPE))
03000 (COND ((AND (MEMQ TYPE (QUOTE (*FSUBR *LSUBR)))
03100 (GETPROP NAME (QUOTE *UNDEF)))
03200 (PRINTMSG (MCONS NAME FLAG (QUOTE (USED AS SUBR))))))
03300 (SETPROP NAME TYPE T)
03400 (REMPROP NAME (QUOTE *UNDEF))
03500 (TYPEFN NAME)
03600 PRINT(COND ((NOT (ATMARGIN)) (LINEF 2)))
03700 (OUTPUTSTAT ENTRY)
03800 LOOP (SETQ STAT (ERRSET (READ)))
03900 (COND ((ATOM STAT) (USERERR READERR-FLUSHLAP)))
04000 (OUTPUTSTAT (CAR STAT))
04100 (COND ((NULL (CAR STAT)) (RETURN NIL)))
04200 (GO LOOP)))
04300
04400 (DFUNC (MAKDEF NAME ARGS BODY TYPE)
04500 (LIST (QUOTE DEFPROP) NAME (LIST (QUOTE LAMBDA) ARGS BODY) TYPE))
04600
00100 (DFUNC (MAPPUT EXP)
00200 (PROG (IND ARGS)
00300 (SETQ IND (CAR EXP))
00400 (SETQ ARGS (CDR EXP))
00500 LOOP (COND ((NULL ARGS) (RETURN EXP)))
00600 (PUTPROP (CAR ARGS) T IND)
00700 (SETQ ARGS (CDR ARGS))
00800 (GO LOOP)))
00900
01000 (DFUNC (PRINTMSG MESSAGE)
01100 (PROG (CHAN LINCNT)
01200 (SETQ CHAN (OUTC MSGCHAN NIL))
01300 (SETQ LINCNT 0)
01400 (COND ((NOT (ATMARGIN)) (LINEF 2)))
01500 (PRINL (CONS (QUOTE *) MESSAGE))
01600 (LINEF 1)
01700 (OUTC CHAN NIL)))
01800
01900 (DFUNC (READLOOP ACTFUN)
02000 (PROG (EXPR)
02100 LOOP (SETQ EXPR (ERRSET (READ)))
02200 (COND ((EQ EXPR (QUOTE $EOF$)) (RETURN NIL)))
02300 (ACTFUN (CAR EXPR))
02400 (GO LOOP)))
02500
02600 (DEFPROP SPECIAL
02700 (LAMBDA (X) (MAPCAR (FUNCTION MAKESPECIAL) X))
02800 FEXPR)
02900
00100 (DFUNC (TELLTALE FILENAME STARTTIME)
00200 (PROG (CHAN UNDS)
00300 (SETQ CHAN (OUTC MSGCHAN NIL))
00400 (CARRETN)
00500 (LINEF 1)
00600 (PRINL (LIST FILENAME (QUOTE COMPILED)))
00700 (PRINL (LIST CODESIZE (QUOTE WORDS)))
00800 (PRINL (LIST CONSTSIZE (QUOTE CONSTANTS)))
00900 (PRINL (LIST (ADD1 (QUOTIENT (DIFFERENCE (TIME) STARTTIME)
01000 1750))
01100 (QUOTE SECONDS)))
01200 (LINEF 2)
01300 UNDF (COND ((NULL UNDFUNS) (GO UNDF1)))
01400 (COND ((HASPROP (CAR UNDFUNS) (QUOTE *UNDEF))
01500 (SETQ UNDS (CONS (CAR UNDFUNS) UNDS))))
01600 (SETQ UNDFUNS (CDR UNDFUNS))
01700 (GO UNDF)
01800 UNDF1(COND ((NULL UNDS) (GO GENF)))
01900 (PRINL (QUOTE (UNDEFINED FUNCTIONS)))
02000 (LINEF 1)
02100 (PRINL UNDS)
02200 (LINEF 2)
02300 GENF (COND ((NULL GENFUNS) (GO END)))
02400 (PRINL (QUOTE (GENERATED FUNCTIONS)))
02500 (LINEF 1)
02600 (PRINL GENFUNS)
02700 (LINEF 2)
02800 END (OUTC CHAN NIL)))
02900
03000 (DFUNC (TYPEFN MESSAGE)
03100 (PROG (CHAN LINCNT)
03200 (COND ((NULL SHOWNAMES) (RETURN NIL)))
03300 (SETQ CHAN (OUTC MSGCHAN NIL))
03400 (SETQ LINCNT 0)
03500 (COND ((ATMARGIN) (LINEF 1)))
03600 (PRINS MESSAGE)
03700 (OUTC CHAN NIL)))
03800
03900 (DEFPROP UNSPECIAL
04000 (LAMBDA (X) (MAPCAR (FUNCTION MAKEUNSPECIAL) X))
04100 FEXPR)
04200
04300 (BEGINBLOCK INITIALIZATION)
04400
04500 (DFUNC (CINIT) (PROG2 (EXCISE) (INITFN (QUOTE CSTART))))
04600
00100 (DFUNC (CSTART)
00200 (PROG NIL
00300 (INITFN NIL)
00400 (COND ((NOT (NULL (ERRSET (INPUT SYS: (COMPLR . INI)) NIL)))
00500 (SYSIN (COMPLR . INI))))
00600 (COND ((NOT (NULL (ERRSET (INPUT DSK: (COMPLR . INI)) NIL)))
00700 (SYSIN DSK: (COMPLR . INI))))
00800 (LINEF 1)
00900 (PRINL (QUOTE (LISP COMPILER)))))
01000
01100 (ENDBLOCK INITIALIZATION)
01200
01300 (MAPDEF COMPEFFECT (COMPACTION DOACT) (MACRO ACTONMACRO))
01400
01500 (MAPDEF COMPACTION (DE DODE) (DECLARE EVAL) (DEFPROP COMPDEF)
01600 (DF DODF) (DM DODM) (LAP FLUSHLAP) (SPECIAL EVAL)
01700 (UNSPECIAL EVAL) (*SUBR MAPPUT) (*FSUBR MAPPUT)
01800 (*LSUBR MAPPUT) (*EXPR MAPPUT) (*FEXPR MAPPUT))
01900
02000 (MAPDEF DEFACTION (EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO DEFMACRO)
02100 (SPECIAL EVAL) (DEFACTION EVAL) (*EXPR DO*EXPR)
02200 (*FEXPR DO*FEXPR) (*SUBR EVAL) (*FSUBR EVAL)
02300 (*LSUBR EVAL))
02400
02500 (SETQ LISTING NIL)
02600
02700 (SETQ OUTDEV (SETQ INDEV (QUOTE DSK:)))
02800
02900 (SETQ OUTEXT (QUOTE LAP))
03000
03100 (SETQ SHOWNAMES T)
03200
03300 (ENDBLOCK TOPLEVEL)
03400
03500 (BEGINBLOCK PASS1)
03600
03700 (DFUNC (DOP1 XPR) ((GETPROP (CAR XPR) (QUOTE P1)) XPR))
03800
03900 (DFUNC (GENFUN EXPR)
04000 (PROG (NAME ARGS CALL)
04100 (COND ((ATOM EXPR) (RETURN EXPR)))
04200 (COND ((NOT (EQ (CAR EXPR) (QUOTE LAMBDA)))
04300 (USERERR NOTLAMBDA-GENFUN)))
04400 (SETQ ARGS (CADR EXPR))
04500 (SETQ CALL (CADDR EXPR))
04600 (COND ((AND (ATOM (CAR CALL)) (EQUAL ARGS (CDR CALL)))
04700 (RETURN (CAR CALL))))
04800 (SETQ NAME (MAKESYM (NEXTSYM (QUOTE SUBFUN)) (CURFUN)))
04900 (SETQ GENFUNS (CONS NAME GENFUNS))
05000 (RETURN (COMPFUNC NAME (LIST (QUOTE SUBR) ARGS CALL) (QUOTE SUBR)))))
05100
00100 (DFUNC (MAPP1 ARGS) (MAPCAR (FUNCTION P1) ARGS))
00200
00300 (DFUNC (NEWNAME OLD)
00400 (PROG (NEW)
00500 (SETQ NEW (ASSOC OLD RENAMELIST))
00600 (COND (NEW (RETURN (CDR NEW))))
00700 (RETURN NIL)))
00800
00900 (DFUNC (P1 XPR)
01000 (PROG (TEM)
01100 (COND ((ATOM XPR) (GO ATOM)))
01200 (COND ((ATOM (CAR XPR)) (GO ATOMC)))
01300 (COND ((EQ (CAAR XPR) (QUOTE LAMBDA)) (RETURN (P1LAM XPR))))
01400 (COND ((EQ (CAAR XPR) (QUOTE LABEL)) (RETURN (P1LABEL XPR))))
01500 (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
01600 ATOM (COND ((CONSTANTP XPR) (RETURN (LIST (QUOTE QUOTE) XPR))))
01700 (COND ((SETQ TEM (NEWNAME XPR)) (RETURN (P1 (CAR TEM)))))
01800 (INCR P1CNT)
01900 (COND ((SPECIALP XPR) (SETQ SPECVARS (ADDTOLIST XPR SPECVARS))
02000 (RETURN XPR)))
02100 (COND ((VARB XPR) (RETURN XPR)))
02200 (PUTLOC XPR P1CNT)
02300 (RETURN XPR)
02400 ATOMC(COND ((CONSTANTP (CAR XPR)) (USERERR CONSTFUN-P1)))
02500 (COND ((SETQ TEM (NEWNAME (CAR XPR)))
02600 (RETURN (P1 (CONS (CAR TEM) (CDR XPR))))))
02700 (COND ((SETQ TEM (GETGET (CAR XPR) (QUOTE PASS1)))
02800 (RETURN ((CADR TEM) XPR))))
02900 (COND ((OR (SPECIALP (CAR XPR)) (MEMBER (CAR XPR) ALLVARS))
03000 (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))))
03100 (RETURN (P1ELSE XPR))))
03200
03300 (DFUNC (P1ANDOR XPR)
03400 (PROG (TEM CT ARGS)
03500 (SETQ TEM LOCVARS)
03600 (SETQ CT P1CNT)
03700 (SETQ ARGS (MAPP1 (CDR XPR)))
03800 (INCR P1CNT)
03900 (P1BUG CT P1CNT TEM)
04000 (INCR P1CNT)
04100 (RETURN (CONS (CAR XPR) ARGS))))
04200
00100 (DFUNC (P1BIND VARS)
00200 (PROG (VAR NEWVARS)
00300 (COND ((AND VARS (ATOM VARS)) (USERERR ATOMICVARLIST-P1BIND)))
00400 LOOP (COND ((NULL VARS) (RETURN (REVERSE NEWVARS))))
00500 (SETQ VAR (CAR VARS))
00600 (COND ((NOT (VARIABLEP VAR)) (USERERR NOTVARIABLE-P1BIND)))
00700 (COND ((MEMBER VAR NEWVARS) (USERWARN VAR REPEATED VARIABLE)))
00800 (COND ((SPECIALP VAR) (SETQ SPECVARS (ADDTOLIST VAR SPECVARS))
00900 (GO ELOOP))
01000 ((MEMBER VAR ALLVARS) (RENAME VAR (SETQ VAR (GENVAR)))))
01100 (PUTLOC VAR 0)
01200 ELOOP(SETQ ALLVARS (ADDTOLIST VAR ALLVARS))
01300 (SETQ NEWVARS (CONS VAR NEWVARS))
01400 (SETQ VARS (CDR VARS))
01500 (GO LOOP)))
01600
01700 (DFUNC (P1BUG LOW HIGH PTR)
01800 (PROG (X)
01900 LOOP (COND ((NULL PTR) (RETURN NIL)))
02000 (SETQ X (CAR PTR))
02100 (COND ((GREATERP (CDR X) LOW) (RPLACD X HIGH)))
02200 (SETQ PTR (CDR PTR))
02300 (GO LOOP)))
02400
02500 (DFUNC (P1COND XPR)
02600 (PROG (TEM CT PAIRS P1SCV)
02700 (SETQ TEM LOCVARS)
02800 (SETQ CT P1CNT)
02900 (SETQ PAIRS (MAPCAR (FUNCTION MAPP1) (CDR XPR)))
03000 (INCR P1CNT)
03100 (P1BUG CT P1CNT TEM)
03200 (INCR P1CNT)
03300 (RETURN (MCONS (CAR XPR) P1SCV PAIRS))))
03400
03500 (DFUNC (P1CONS XPR)
03600 (COND ((NOT (EQ (LENGTH (CDR XPR)) 2)) (USERERR ARGNO-P1CONS))
03700 ((NULL (CADDR XPR)) (LIST (QUOTE NCONS) (P1 (CADR XPR))))
03800 (T (LIST (QUOTE CONS) (P1 (CADR XPR)) (P1 (CADDR XPR))))))
03900
04000 (DFUNC (P1ELSE XPR)
04100 (PROG NIL
04200 (SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS))
04300 (PUTPROP (CAR XPR) T (QUOTE *UNDEF))
04400 (RETURN (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))))
04500
04600 (DFUNC (P1ERRSET XPR)
04700 (COND ((ATOM (CADR XPR)) XPR)
04800 (T (MCONS (CAR XPR)
04900 (LIST (GENFUN (LIST (QUOTE LAMBDA) NIL (CADR XPR))))
05000 (CDDR XPR)))))
05100
00100 (DFUNC (P1EVAL XPR)
00200 (PROG (CDRXPR)
00300 (SETQ CDRXPR (P1SUBRARGS (CDR XPR)))
00400 (COND ((NOT (NULL (CDR CDRXPR)))
00500 (RETURN (CONS (QUOTE EVAL) CDRXPR))))
00600 (RETURN (CONS (QUOTE *EVAL) CDRXPR))))
00700
00800 (DFUNC (P1FUNCTION XPR)
00900 (LIST (COND ((EQ (CAR XPR) (QUOTE FUNCTION)) (QUOTE QUOTE)) (T (CAR XPR)))
01000 (GENFUN (CADR XPR))))
01100
01200 (DFUNC (P1GO XPR)
01300 (PROG NIL
01400 (COND ((NOT INPROG) (USERERR NOTINPROG-P1GO)))
01500 (COND ((ATOM (CADR XPR)) (RETURN XPR)))
01600 (RETURN (LIST (CAR XPR) (P1 (CADR XPR))))))
01700
01800 (DFUNC (P1LABEL XPR)
01900 (PROG (FN)
02000 (INITPROP (CADAR XPR) (QUOTE FUNVAR) T)
02100 (SETQ FN (P1 (LIST (QUOTE FUNCTION) (CADDAR XPR))))
02200 (DELETEPROP (CADAR XPR) (QUOTE FUNVAR))
02300 (RETURN (P1 (LIST (QUOTE PROG)
02400 (LIST (CADAR XPR))
02500 (LIST (QUOTE SETQ) (CADAR XPR) FN)
02600 (LIST (QUOTE RETURN)
02700 (CONS (CADAR XPR) (CDR XPR))))))))
02800
02900 (DFUNC (P1LAM XPR)
03000 (PROG (ARGS LAML BODY SAVERENAMELIST)
03100 (SETQ SAVERENAMELIST RENAMELIST)
03200 (SETQ ARGS (P1SUBRARGS (CDR XPR)))
03300 (SETQ LAML (P1BIND (CADAR XPR)))
03400 (SETQ BODY (P1 (CADDAR XPR)))
03500 (INCR P1CNT)
03600 (SETQ RENAMELIST SAVERENAMELIST)
03700 (RETURN (CONS (LIST (QUOTE LAMBDA) LAML BODY) ARGS))))
03800
00100 (DFUNC (P1PROG X)
00200 (PROG (TAGLIST P1SCNT PR TEM P1LL INPROG SAVERENAMELIST)
00300 (COND ((NULL (CDR X)) (USERERR PROGTOOSHORT-P1PROG)))
00400 (SETQ INPROG T)
00500 (SETQ X (CDR X))
00600 (SETQ SAVERENAMELIST RENAMELIST)
00700 (SETQ P1LL (P1BIND (CAR X)))
00800 (SETQ TEM LOCVARS)
00900 (SETQ P1SCNT (INCR P1CNT))
01000 LOOP1(SETQ X (CDR X))
01100 (COND ((NULL X) (GO END1)))
01200 (INCR P1CNT)
01300 (COND ((ATOM (CAR X))
01400 (COND ((ASSOC (CAR X) TAGLIST)
01500 (USERWARN (CAR X) MULTIPLY DEFINED TAG)))
01600 (SETQ TAGLIST (CONS (CONS (CAR X) (GENTAG)) TAGLIST))
01700 (SETQ PR (CONS (CAR X) PR)))
01800 (T (SETQ PR (CONS (P1 (CAR X)) PR))))
01900 (GO LOOP1)
02000 END1 (INCR P1CNT)
02100 (P1BUG P1SCNT P1CNT TEM)
02200 (SETQ TEM (GETPROP (QUOTE LOCVARS) (QUOTE VALUE)))
02300 LOOP (COND ((NULL (CDR TEM)) (GO END)))
02400 (COND ((AND (MEMBER (CAADR TEM) P1LL) (ZEROP (CDADR TEM)))
02500 (USERWARN (CAADR TEM) UNUSED PROG VARIABLE)
02600 (SETQ SPECVARS (ADDTOLIST (CAADR TEM) SPECVARS))
02700 (MAKESPECIAL (CAADR TEM))))
02800 ELOOP(SETQ TEM (CDR TEM))
02900 (GO LOOP)
03000 END (INCR P1CNT)
03100 (SETQ RENAMELIST SAVERENAMELIST)
03200 (RETURN (MCONS (QUOTE PROG) TAGLIST P1LL (REVERSE PR)))))
03300
03400 (DFUNC (P1RETURN XPR)
03500 (COND ((NOT INPROG) (USERERR NOTINPROG-P1RETURN))
03600 (T (LIST (QUOTE RETURN)
03700 (P1 (COND ((NULL (CDR XPR)) NIL) (T (CADR XPR))))))))
03800
03900 (DFUNC (P1SETQ XPR)
04000 (PROG (VAR TEM VAL)
04100 (COND ((NOT (VARIABLEP (CAR XPR)))
04200 (USERERR NOTVARIABLE-P1SETQ)))
04300 (SETQ VAR (COND ((SETQ TEM (NEWNAME (CADR XPR))) (CAR TEM))
04400 (T (CADR XPR))))
04500 (VARB VAR)
04600 (SETQ P1SCV (CONS VAR P1SCV))
04700 (SETQ VAL (P1 (CADDR XPR)))
04800 (INCR P1CNT)
04900 (INCR P1CNT)
05000 (RETURN (LIST (QUOTE SETQ) VAR VAL))))
05100
00100 (DFUNC (P1STORE XPR)
00200 (PROG (ARG1 ARG2)
00300 (SETQ ARG2 (P1 (CADDR XPR)))
00400 (SETQ ARG1 (P1 (CADR XPR)))
00500 (RETURN (LIST (CAR XPR) ARG1 ARG2))))
00600
00700 (DFUNC (P1SUBRARGS ARGS)
00800 (COND ((GREATERP (LENGTH ARGS) NACS) (USERERR EXTRAARGS-P1SUBRARGS))
00900 (T (MAPP1 ARGS))))
01000
01100 (DFUNC (PASS1 EXPR)
01200 (PROG (ALLVARS LL RENAMELIST P1SCNT P1SCV INPROG FOUNDFREE LOCVS)
01300 (SETQ INPROG NIL)
01400 (SETQ P1CNT 1)
01500 (SETQ LOCVARS (SETQ SPECVARS NIL))
01600 (SETQ LL (P1BIND (CADR EXPR)))
01700 (COND ((GREATERP (LENGTH LL) NACS) (USERERR EXTRAARGS-PASS1)))
01800 (SETQ EXPR (LIST (CAR EXPR) LL (P1 (CADDR EXPR))))
01900 (COND ((NOT (NULL FOUNDFREE)) (USERWARN (REVERSE FOUNDFREE)
02000 UNDECLARED
02100 FREE
02200 VARIABLES)))
02300 (SETQ LOCVS LOCVARS)
02400 (SETQ LOCVARS NIL)
02500 LOOP (COND ((NULL LOCVS) (RETURN EXPR)))
02600 (COND ((NOT (SPECIALP (CAAR LOCVS)))
02700 (SETQ LOCVARS (CONS (CAR LOCVS) LOCVARS))
02800 (SETPROP (CAAR LOCVS) (QUOTE LOCAL) T))
02900 (T (SETQ SPECVARS (ADDTOLIST (CAAR LOCVS) SPECVARS))))
03000 (SETQ LOCVS (CDR LOCVS))
03100 (GO LOOP)))
03200
03300 (DFUNC (PASS1FSUBR XPR) XPR)
03400
03500 (DFUNC (PASS1FUNVAR XPR)
03600 (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
03700
03800 (DFUNC (PASS1LSUBR XPR) (CONS (CAR XPR) (MAPP1 (CDR XPR))))
03900
04000 (DFUNC (PASS1MACRO XPR) (P1 ((GETPROP (CAR XPR) (QUOTE MACRO)) XPR)))
04100
04200 (DFUNC (PASS1SUBR XPR) (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))
04300
04400 (DFUNC (PASS1UNDEF XPR)
04500 (PROG2 (SETQ UNDFUNS (ADDTOLIST (CAR XPR) UNDFUNS))
04600 (PASS1SUBR XPR)))
04700
00100 (DFUNC (PUTLOC IVAR NUMBER)
00200 (PROG (TEM)
00300 (SETQ TEM (ASSOC IVAR LOCVARS))
00400 (COND (TEM (RETURN (RPLACD TEM NUMBER))))
00500 (RETURN (SETQ LOCVARS (CONS (CONS IVAR NUMBER) LOCVARS)))))
00600
00700 (DFUNC (RENAME OLD NEW)
00800 (SETQ RENAMELIST (CONS (LIST OLD NEW) RENAMELIST)))
00900
01000 (DFUNC (SPECIALP VAR) (HASPROP VAR (QUOTE SPECIAL)))
01100
01200 (DFUNC (VARB X)
01300 (PROG NIL
01400 (COND ((MEMBER X ALLVARS) (RETURN NIL))
01500 ((SPECIALP X) (GO SPEC)))
01600 (SETQ FOUNDFREE (CONS X FOUNDFREE))
01700 (MAKESPECIAL X)
01800 SPEC (SETQ SPECVARS (ADDTOLIST X SPECVARS))
01900 (SETQ ALLVARS (ADDTOLIST X ALLVARS))
02000 (RETURN T)))
02100
02200 (DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX))))
02300
02400 (MAPDEF PASS1 (EXPR PASS1SUBR) (*EXPR PASS1SUBR) (SUBR PASS1SUBR)
02500 (*SUBR PASS1SUBR) (*UNDEF PASS1UNDEF)
02600 (LSUBR PASS1LSUBR) (*LSUBR PASS1LSUBR)
02700 (FEXPR PASS1FSUBR) (*FEXPR PASS1FSUBR)
02800 (FSUBR PASS1FSUBR) (*FSUBR PASS1FSUBR) (P1 DOP1)
02900 (FUNVAR PASS1FUNVAR) (MACRO PASS1MACRO))
03000
03100 (MAPDEF P1 (COND P1COND) (GO P1GO) (PROG P1PROG) (EVAL P1EVAL)
03200 (ERRSET P1ERRSET) (SETQ P1SETQ) (STORE P1STORE)
03300 (AND P1ANDOR) (CONS P1CONS) (OR P1ANDOR)
03400 (*FUNCTION P1FUNCTION) (FUNCTION P1FUNCTION)
03500 (RETURN P1RETURN))
03600
03700 (BEGINBLOCK INTERNALMACROS)
03800
03900 (DEFPROP INMACRO PASS1INMACRO PASS1)
04000
04100 (DFUNC (PASS1INMACRO XPR) (P1 ((GETPROP (CAR XPR) (QUOTE INMACRO)) XPR)))
04200
04300 (DEFPROP INMACRO
04400 (LAMBDA (DF)
04500 (COMPFUNC (CADR DF) (CONS (QUOTE SUBR) (CDADDR DF)) (QUOTE INMACRO)))
04600 DEFACTION)
04700
00100 (DEFPROP APPEND
00200 (LAMBDA (L)
00300 (COND ((NULL (CDR L)) NIL)
00400 ((NULL (CDDR L)) (CADR L))
00500 (T (LIST (QUOTE *APPEND) (CADR L) (CONS (CAR L) (CDDR L))))))
00600 INMACRO)
00700
00800 (DEFPROP LIST
00900 (LAMBDA (L)
01000 (COND ((NULL (CDR L)) NIL)
01100 ((NULL (CDDR L)) (CONS (QUOTE NCONS) (CDR L)))
01200 (T (LIST (QUOTE CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
01300 INMACRO)
01400
01500 (DEFPROP NOT (LAMBDA (L) (CONS (QUOTE NULL) (CDR L))) INMACRO)
01600
01700 (DEFPROP ZEROP (LAMBDA (L) (LIST (QUOTE EQ) (CADR L) (QUOTE 0))) INMACRO)
01800
01900 (ENDBLOCK INTERNALMACROS)
02000
02100 (ENDBLOCK PASS1)
02200
02300 (BEGINBLOCK PASS2)
02400
02500 (DFUNC (ACEFFECTS FN)
02600 (COND ((SETQ FN (SEEKPROP FN (QUOTE ACS))) (CADR FN)) (T ALLACS)))
02700
02800 (DFUNC (ACNUMP X)
02900 (AND (NUMBERP X) (GREATERP X 0) (LESSP X (ADD1 NACS))))
03000
03100 (DFUNC (BINDVARS VARS LAMBDAP)
03200 (PROG (VAR ACNUM SPFLG)
03300 (SETQ ACNUM 1)
03400 A (COND ((NULL VARS) (RETURN SPFLG)))
03500 (SETQ VAR (CAR VARS))
03600 (COND ((SPECVARP VAR) (GO SP1))
03700 ((ASSOC VAR LOCVARS) (GO LV1))
03800 (T (COMPERR FUNNYVAR-BINDVARS) (GO SP2)))
03900 LV1 (COND (LAMBDAP (SETSLOT ACNUM (LIST VAR))))
04000 SP2 (SETQ ACNUM (ADD1 ACNUM))
04100 (SETQ VARS (CDR VARS))
04200 (GO A)
04300 SP1 (COND ((NOT PRGSPFLG) (GO B)))
04400 SP3 (OUTINST (LIST 0
04500 (COND (LAMBDAP ACNUM) (T 0))
04600 (LIST (QUOTE SPECIAL) VAR)))
04700 (GO LV1)
04800 B (SETQ PRGSPFLG (SETQ SPFLG T))
04900 (OUTINST (QUOTE (JSP 6 SPECBIND)))
05000 (GO SP3)))
05100
00100 (DFUNC (BOOLAND EXP VALAC TAG FLAG)
00200 (PROG NIL
00300 (BOOL2 (CDR EXP) VALAC TAG T FLAG)
00400 (INCR P2CNT)
00500 (INCR P2CNT)))
00600
00700 (DFUNC (BOOLEQ EXP VALAC TAG FLAG)
00800 (PROG NIL
00900 (BOOLEQ1 (CDR EXP) VALAC TAG FLAG)
01000 (OUTJRST TAG)
01100 (RSLSET TAG)
01200 (RETURN NIL)))
01300
01400 (DFUNC (BOOLEQ1 EXP VALAC TAG F)
01500 (PROG (ARG1 ARG2 LOC1 LOC2 AC MEM)
01600 (COND ((NOT (EQ (LENGTH EXP) 2)) (USERERR ARGNOERR-BOOLEQ1)))
01700 (SETQ ARG1 (COMP (CAR EXP) (FREEAC)))
01800 (SETQ ARG2 (COMP (CADR EXP) (FREEAC)))
01900 (SETQ LOC2 (LOC ARG2))
02000 (SETQ LOC1 (LOC ARG1))
02100 (RST TAG)
02200 (COND ((ACNUMP LOC1) (SETQ AC LOC1) (SETQ MEM (LOC ARG2)))
02300 ((ACNUMP LOC2) (SETQ AC LOC2) (SETQ MEM (LOC ARG1)))
02400 (T (LOADARG (SETQ AC (FREEAC)) ARG1)
02500 (SETQ MEM (LOC ARG2))))
02600 (REMOVE ARG1)
02700 (REMOVE ARG2)
02800 (SAVEACS)
02900 (OUT1 (COND (F (QUOTE CAMN)) (T (QUOTE CAME))) AC MEM)))
03000
03100 (DFUNC (BOOLEXPR EXP VALAC TAG FLAG MINDEPTH)
03200 (PROG (TEM)
03300 (COND ((ATOM EXP) (GO ELSE)))
03400 (COND ((SETQ TEM (SEEKPROP (CAR EXP) (QUOTE BOOL)))
03500 (RETURN ((CADR TEM) EXP VALAC TAG FLAG))))
03600 ELSE (SETQ EXP (PUTINAC (COMP EXP VALAC)
03700 (COND (VALAC) ((FREEAC)))))
03800 (OUTCJMP FLAG EXP TAG)
03900 (COND (FLAG (RSLSET TAG) (SETSLOT EXP (QUOTE (QUOTE NIL))))
04000 (T (SETQ FLAG (SLOTCONT EXP))
04100 (SETSLOT EXP (QUOTE (QUOTE NIL)))
04200 (RSLSET TAG)
04300 (SETSLOT EXP FLAG)))))
04400
00100 (DFUNC (BOOL2 EXP VALAC TAG F1 F2)
00200 (PROG (G)
00300 (CLEAR1)
00400 (RST TAG)
00500 (PUTPROP (SETQ G (GENTAG)) (TOPCOPY PDL) (QUOTE LEVEL))
00600 A (COND ((NULL EXP) (COND (F2 (OUTJRST TAG))) (GO C)))
00700 (COND ((AND F2 (NULL (CDR EXP))) (GO B)))
00800 (BOOLEXPR (CAR EXP)
00900 VALAC
01000 (COND (F2 G) (T TAG))
01100 (NOT F1)
01200 MINDEPTH)
01300 (SETQ EXP (CDR EXP))
01400 (GO A)
01500 B (BOOLEXPR (CAR EXP) VALAC TAG F1 MINDEPTH)
01600 (OUTENDTAG G)
01700 C (CLEAR2BOTH)
01800 (CLEARACS)))
01900
02000 (DFUNC (BOOLNULL EXP VALAC TAG FLAG)
02100 (BOOLEXPR (CADR EXP) VALAC TAG (NOT FLAG) MINDEPTH))
02200
02300 (DFUNC (BOOLOR EXP VALAC TAG FLAG)
02400 (PROG NIL
02500 (BOOL2 (CDR EXP) VALAC TAG NIL (NOT FLAG))
02600 (INCR P2CNT)
02700 (INCR P2CNT)))
02800
02900 (DFUNC (BOOLQUOTE EXP VALAC TAG FLAG)
03000 (BOOL2 NIL VALAC TAG NIL (IFIF FLAG (CADR EXP))))
03100
03200 (DFUNC (BOOLVALUE VALAC EFFECTS TAG)
03300 (PROG NIL
03400 (COND ((NOT EFFECTS) (OUT1 (QUOTE TDZA) VALAC VALAC)))
03500 (OUTENDTAG TAG)
03600 (COND ((NOT EFFECTS) (OUT1 (QUOTE MOVEI) VALAC (QUOTE (QUOTE T)))))
03700 (RETURN (COND (EFFECTS NIL) (T (MARKVAL VALAC))))))
03800
03900 (DFUNC (CALLFSUBR XPR VALAC EFFECTS)
04000 (PROG (FUN ARGS VAL)
04100 (SETQ FUN (CAR XPR))
04200 (SETQ ARGS (CDR XPR))
04300 (CLEAR2BOTH)
04400 (LOADARG FARGAC (LIST (QUOTE QUOTE) ARGS))
04500 (PROTECTACS FUN)
04600 (COND ((NOT (NULL VALAC)) (SETQ VAL (MARKVAL VALUEAC))))
04700 (OUTCALL 17 FUN)
04800 (RETURN VAL)))
04900
00100 (DFUNC (CALLFUNARGS XPR VALAC EFFECTS)
00200 (PROG (FUN ARGS FUNARGS LOCS VAL)
00300 (SETQ FUN (CAR XPR))
00400 (SETQ ARGS (CDR XPR))
00500 (SETQ FUNARGS (COMP FUN VALAC))
00600 (SETQ LOCS (COMPARGS ARGS))
00700 (CLRCCLST LOCS)
00800 (LOADSUBRARGS LOCS)
00900 (CLEAR2BOTH)
01000 (CLEARACS)
01100 (COND ((NOT (NULL VALAC)) (SETQ VAL (MARKVAL VALUEAC))))
01200 (OUTCALLF (LENGTH LOCS) (LOC FUNARGS))
01300 (REMOVE FUNARGS)
01400 (RETURN VAL)))
01500
01600 (DFUNC (CALLLSUBR XPR VALAC EFFECTS)
01700 (PROG (FUN ARGS NARGS HOME INST RETTAG TEM VAL)
01800 (SETQ FUN (CAR XPR))
01900 (SETQ ARGS (CDR XPR))
02000 (CLEAR1)
02100 (SETQ NARGS (LENGTH ARGS))
02200 (SLOTPUSH (QUOTE (NIL . TAKEN)))
02300 (OUTPUSH (GENCONST 0 0 (SETQ RETTAG (GENTAG)) 0 0))
02400 LOOP (COND ((NULL ARGS) (GO CALL)))
02500 (SETQ HOME (TOPCOPY PDL))
02600 (SETQ INST (COMP (CAR ARGS) VALAC))
02700 (RESTORE HOME)
02800 (SETQ TEM (LOC INST))
02900 (SLOTPUSH (QUOTE (NIL . TAKEN)))
03000 (OUTPUSH TEM)
03100 (REMOVE INST)
03200 (SETQ ARGS (CDR ARGS))
03300 (GO LOOP)
03400 CALL (SETQ TEM (PDLDEPTH))
03500 (SAVEACS)
03600 (COND ((NOT (EQ (PDLDEPTH) TEM))
03700 (COMPERR PDLTOOLONG-LSUBRCALL)))
03800 (OUTINST (LIST (QUOTE MOVNI) 6 NARGS))
03900 LLOOP(SLOTPOP)
04000 (COND ((ZEROP NARGS) (GO CALL1)))
04100 (SETQ NARGS (SUB1 NARGS))
04200 (GO LLOOP)
04300 CALL1(CLEAR2BOTH)
04400 (CLEARACS)
04500 (COND ((NOT (NULL VALAC)) (SETQ VAL (MARKVAL VALUEAC))))
04600 (OUTJCALL 16 FUN)
04700 (OUTTAG RETTAG)
04800 (RETURN VAL)))
04900
00100 (DFUNC (CALLSUBR XPR VALAC EFFECTS)
00200 (PROG (FUN ARGS NARGS LOCS TEM VAL)
00300 (SETQ FUN (CAR XPR))
00400 (SETQ ARGS (CDR XPR))
00500 (SETQ LOCS (COMPARGS ARGS))
00600 (SETQ NARGS (LENGTH LOCS))
00700 (COND ((AND (SETQ TEM (SEEKPROP FUN (QUOTE COMMU)))
00800 (EQ NARGS 2)
00900 (EQ (ILOC (CAR LOCS) VALUEAC) VALUEAC))
01000 (SETQ LOCS (REVERSE LOCS))
01100 (SETQ FUN (CADR TEM))))
01200 (SETQ TEM (SIDEEFFECTS FUN))
01300 (COND (TEM (CLRCCLST LOCS)))
01400 (LOADSUBRARGS LOCS)
01500 (COND (TEM (CLEAR2BOTH)))
01600 (PROTECTACS FUN)
01700 (COND ((NOT (NULL VALAC)) (SETQ VAL (MARKVAL VALUEAC))))
01800 (OUTCALL NARGS FUN)
01900 (RETURN VAL)))
02000
02100 (DFUNC (CLEAR1)
02200 (PROG NIL (CLEAR1BOTH) (SAVEACS) (RETURN (CLRPVARS))))
02300
02400 (DFUNC (CLEAR1BOTH) (PROG NIL (CLRCCLST1 VALUEAC) (CLRSPLD)))
02500
02600 (DFUNC (CLEAR2BOTH) (PROG NIL (CLRCCLST2 VALUEAC) (CLRSPLD)))
02700
02800 (DFUNC (CLEARAC ACNO) (PROG NIL (CPUSH ACNO) (SETSLOT ACNO NIL)))
02900
03000 (DFUNC (CLEARITALL) (PROG NIL (CLEAR2BOTH) (CLEARACS)))
03100
03200 (DFUNC (CLEARACS)
03300 (PROG (ACNO)
03400 (SETQ ACNO NACS)
03500 LOOP (COND ((ZEROP ACNO) (RETURN NIL)))
03600 (CLEARAC ACNO)
03700 (SETQ ACNO (SUB1 ACNO))
03800 (GO LOOP)))
03900
04000 (DFUNC (CLRCCLST DATA)
04100 (PROG (CCL)
04200 (SETQ CCL CCLST)
04300 LOOP (COND ((NULL CCL) (RETURN NIL)))
04400 (COND ((ASSOC (CAAR CCL) DATA) (GO ELOOP)))
04500 (CSFUN (CAR CCL) VALUEAC)
04600 ELOOP(SETQ CCL (CDR CCL))
04700 (GO LOOP)))
04800
00100 (DFUNC (CLRCCLST1 AC)
00200 (PROG (CCL)
00300 (SETQ CCL CCLST)
00400 LOOP (COND ((NULL CCL) (RETURN NIL)))
00500 (CSFUN (CAR CCL) AC)
00600 (SETQ CCL (CDR CCL))
00700 (GO LOOP)))
00800
00900 (DFUNC (CLRCCLST2 AC)
01000 (PROG NIL
01100 LOOP (COND ((NULL CCLST) (RETURN NIL)))
01200 (CSFUN (CAR CCLST) AC)
01300 (SETQ CCLST (CDR CCLST))
01400 (GO LOOP)))
01500
01600 (DFUNC (CLRPVARS)
01700 (PROG NIL
01800 (COND ((NOT PROGSW) (RETURN NIL)))
01900 (SETQ PROGSW NIL)
02000 LOOP (COND ((NULL PROGVARS) (SETQ PRSSL (TOPCOPY PDL))
02100 (SETQ MINDEPTH (PDLDEPTH))
02200 (RETURN NIL))
02300 ((NOT (ILOC (CONS (CAR PROGVARS) P2CNT) VALUEAC))
02400 (INITZ (CAR PROGVARS))))
02500 (SETQ PROGVARS (CDR PROGVARS))
02600 (GO LOOP)))
02700
02800 (DFUNC (CLRSPLD)
02900 (PROG NIL
03000 LOOP (COND ((NULL SPLDLST) (RETURN NIL)))
03100 (CLRSPVAR (CAR SPLDLST))
03200 (SETQ SPLDLST (CDR SPLDLST))
03300 (GO LOOP)))
03400
03500 (DFUNC (CLRSPVAR L)
03600 (PROG (LOC)
03700 (SETQ LOC (ILOC (CONS (CAR L) P2CNT) VALUEAC))
03800 (COND ((NOT (NUMBERP LOC)) (OUTSPECPUSH (CAR L)))
03900 ((ACNUMP LOC) (SLOTPUSH (SLOTCONT LOC)) (OUTPUSH LOC)))
04000 (RETURN NIL)))
04100
04200 (DFUNC (COMP XPR VALAC) (COMPEXPR XPR VALAC NIL))
04300
04400 (DFUNC (COMPARGS ARGS)
04500 (PROG (ARGNO RESULT)
04600 (SETQ ARGNO 0)
04700 LOOP (COND ((NULL ARGS) (RETURN RESULT)))
04800 (SETQ ARGNO (ADD1 ARGNO))
04900 (SETQ RESULT (CONS (COMP (CAR ARGS) ARGNO) RESULT))
05000 (SETQ ARGS (CDR ARGS))
05100 (GO LOOP)))
05200
00100 (DFUNC (COMPE XPR VALAC) (REMOVE (COMPEXPR XPR VALAC T)))
00200
00300 (DFUNC (COMPEXPR XPR VALAC EFFECTS)
00400 (PROG (TEM)
00500 (COND ((ATOM XPR) (GO ATOM)))
00600 (COND ((ATOM (CAR XPR)) (GO ATOMC)))
00700 (COND ((EQ (CAAR XPR) (QUOTE LAMBDA))
00800 (RETURN (INTERNALLAMBDA XPR VALAC EFFECTS))))
00900 (RETURN (CALLFUNARGS XPR VALAC EFFECTS))
01000 ATOM (SETQ TEM (CONS XPR (INCR P2CNT)))
01100 (COND ((SPECVARP XPR) (SETQ SPLDLST (CONS TEM SPLDLST))))
01200 (SETQ LDLST (CONS TEM LDLST))
01300 (RETURN TEM)
01400 ATOMC(COND ((SETQ TEM (GETGET (CAR XPR) (QUOTE PASS2)))
01500 (RETURN ((CADR TEM) XPR VALAC EFFECTS))))
01600 (COND ((OR (SPECVARP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
01700 (RETURN (CALLFUNARGS XPR VALAC EFFECTS))))
01800 (RETURN (P2ELSE XPR VALAC EFFECTS))))
01900
02000 (DFUNC (COPT FUN AC ARGLOC)
02100 (PROG (CCL TEM YLOC)
02200 (SETQ YLOC (ILOC ARGLOC AC))
02300 (SETQ CCL CCLST)
02400 LOOP (COND ((NULL CCL) (RETURN NIL))
02500 ((AND (EQ FUN (CADAR CCL))
02600 (EQUAL (ILOC (CDDAR CCL) AC) YLOC)
02700 (ILOC (SETQ TEM (LIST (CAAR CCL))) AC))
02800 (RETURN TEM)))
02900 (SETQ CCL (CDR CCL))
03000 (GO LOOP)))
03100
00100 (DFUNC (CPUSH ACNO)
00200 (PROG (TEMPDL SLOTNO SLOTCON HOLDSLOT)
00300 (COND ((NOT (DVP (SETQ SLOTCON (SLOTCONT ACNO))))
00400 (RETURN NIL)))
00500 (COND ((LESSP ACNO 1) (GO MAKE)))
00600 START(SETQ SLOTNO 0)
00700 (SETQ TEMPDL PDL)
00800 LOOP (COND ((NULL TEMPDL) (GO NONE)))
00900 (COND ((DVP (CAR TEMPDL)) (GO ELOOP)))
01000 (COND ((OR (NOT (NUMBERP (CDAR TEMPDL)))
01100 (SPECVARP (CAAR TEMPDL)))
01200 (SETQ HOLDSLOT SLOTNO)))
01300 (COND ((EQ (CAR SLOTCON) (CAAR TEMPDL)) (GO FOUND)))
01400 ELOOP(SETQ TEMPDL (CDR TEMPDL))
01500 (SETQ SLOTNO (SUB1 SLOTNO))
01600 (GO LOOP)
01700 FOUND(SETSLOT SLOTNO SLOTCON)
01800 (COND ((NULL (CDR SLOTCON))
01900 (SETSLOT ACNO (CONS (CAR SLOTCON) (QUOTE DUP)))))
02000 (OUTMOVEM ACNO SLOTNO)
02100 (RETURN NIL)
02200 NONE (COND (HOLDSLOT (SETQ SLOTNO HOLDSLOT) (GO FOUND)))
02300 MAKE (COND ((AND PROGSW (NOT (ASSOC (CAR SLOTCON) LOCVARS)))
02400 (SETQ TEMPDL (PDLDEPTH))
02500 (CLRPVARS)
02600 (COND ((LESSP ACNO 1)
02700 (SETQ ACNO (PLUS ACNO
02800 (DIFFERENCE TEMPDL
02900 (PDLDEPTH))))))))
03000 (SLOTPUSH SLOTCON)
03100 (COND ((NULL (CDR SLOTCON))
03200 (SETSLOT ACNO (CONS (CAR SLOTCON) (QUOTE DUP)))))
03300 (OUTPUSH ACNO)
03400 (RETURN NIL)))
03500
03600 (DFUNC (CSFUN L AC)
03700 (PROG (Y)
03800 (COND ((AND (SETQ Y (ASSOC (CAR L) LDLST)) (NOT (ILOC Y AC)))
03900 (LOADCARCDR L AC)))))
04000
04100 (DFUNC (CSTEP FUN AC ARGLOC)
04200 (PROG (TEM)
04300 (COND ((NULL FUN) (RETURN (LIST ARGLOC))))
04400 (RETURN (CONS (CAR (SETQ TEM (GETPROP FUN (QUOTE CARCDR))))
04500 (CSTEP (CDR TEM) AC ARGLOC)))))
04600
04700 (DFUNC (DOP2 XPR VALAC EFFECTS)
04800 ((GETPROP (CAR XPR) (QUOTE P2)) XPR VALAC EFFECTS))
04900
00100 (DFUNC (DVP X)
00200 (PROG (Y Z)
00300 (COND ((NULL X) (RETURN NIL)))
00400 (COND ((EQ (CAR X) (QUOTE QUOTE)) (RETURN NIL)))
00500 (COND ((EQ (CDR X) (QUOTE DUP)) (RETURN NIL)))
00600 (COND ((EQ (CDR X) (QUOTE TAKEN)) (RETURN T)))
00700 (COND ((AND (SPECVARP (CAR X)) (NULL (CDR X))) (RETURN NIL)))
00800 (COND ((AND (SETQ Y (ASSOC (CAR X) LOCVARS))
00900 (NULL (CDR X))
01000 (LESSP P2CNT (CDR Y)))
01100 (RETURN T)))
01200 (SETQ Z LDLST)
01300 LOOP (COND ((NULL Z)
01400 (RETURN (COND ((SETQ Z (ASSOC (CAR X) VARLIST))
01500 (DVP (CONS (CDR Z) (CDR X))))
01600 (T NIL)))))
01700 (COND ((AND (EQ (CAAR Z) (CAR X))
01800 (EQUAL (LOC (COND ((NUMBERP (CDR X)) X)
01900 (T (CONS (CAR X) P2CNT))))
02000 (LOC (CAR Z))))
02100 (RETURN T)))
02200 (SETQ Z (CDR Z))
02300 (GO LOOP)))
02400
02500 (DFUNC (EQUIVTAG PTAG)
02600 (PROG (LTAG)
02700 (COND ((SETQ LTAG (ASSOC PTAG GOLIST)) (RETURN (CDR LTAG))))
02800 (USERWARN PTAG UNDEFINED TAG)
02900 (RETURN EXIT)))
03000
03100 (DFUNC (EXITBUM SPECFLAG)
03200 (PROG (TEM1 TEM2)
03300 (COND ((SETQ TEM1 (ASSOC (CAAR LASTOUT)
03400 (QUOTE ((CALL JCALL) (PUSHJ JRST)))))
03500 (SETQ TEM2 (CAR LASTOUT))
03600 (SETQ LASTOUT NIL)
03700 (KILLPDL)
03800 (OUTINST TEM2)
03900 (COND ((NOT SPECFLAG)
04000 (SETQ TEM2 (CAR LASTOUT))
04100 (SETQ LASTOUT NIL)
04200 (OUTINST (MCONS (CADR TEM1)
04300 (SUBST 0 (QUOTE P) (CADR TEM2))
04400 (CDDR TEM2)))
04500 (RETURN NIL)))))
04600 (KILLPDL)
04700 (COND (SPECFLAG (OUTINST (QUOTE (JRST 0 SPECSTR))))
04800 (T (OUTINST (QUOTE (POPJ P)))))))
04900
05000 (DFUNC (FREEAC) (FREEAC1 VALUEAC))
05100
00100 (DFUNC (FREEAC1 BEST)
00200 (PROG (ACNO ACCS)
00300 (COND ((AND (NOT (NULL BEST)) (NOT (DVP (SLOTCONT BEST))))
00400 (RETURN BEST)))
00500 (SETQ ACCS ACS)
00600 (SETQ ACNO 1)
00700 LOOP (COND ((NULL ACCS) (COND ((NULL BEST) (RETURN NIL))
00800 (T (CPUSH BEST) (RETURN BEST)))))
00900 (COND ((NOT (DVP (CAR ACCS))) (RETURN ACNO)))
01000 (SETQ ACCS (CDR ACCS))
01100 (SETQ ACNO (ADD1 ACNO))
01200 (GO LOOP)))
01300
01400 (DFUNC (FINDFREEAC) (FREEAC1 NIL))
01500
01600 (DFUNC (FREEZE VAR) (PROG NIL (FREEZE1 VAR ACS) (FREEZE1 VAR PDL)))
01700
01800 (DFUNC (FREEZE1 X Z)
01900 (PROG NIL
02000 LP (COND ((NULL Z) (RETURN NIL))
02100 ((EQ X (CAAR Z))
02200 (COND ((OR (NULL (CDAR Z)) (EQ (CDAR Z) (QUOTE DUP)))
02300 (RPLACA Z (CONS X P2CNT))))))
02400 (SETQ Z (CDR Z))
02500 (GO LP)))
02600
02700 (DFUNC (GENCONST OP AC AD IN IB)
02800 (PROG (ANS)
02900 (COND ((NOT (ZEROP IB)) (SETQ ANS (LIST *AT))))
03000 (SETQ ANS (APPEND ANS (LIST AC AD IN)))
03100 (SETQ ANS (CONS OP ANS))
03200 (RETURN (CONS (QUOTE C) ANS))))
03300
03400 (DFUNC (GETSLOT NO)
03500 (COND ((NOT (NUMBERP NO)) (COMPERR NOTSLOT-GETSLOT))
03600 ((GREATERP NO NACS) (PRINTMSG NO) (COMPERR NOTAC-GETSLOT))
03700 ((GREATERP NO 0) (NTHCDR (SUB1 NO) ACS))
03800 ((GREATERP (ABS NO) (PDLDEPTH)) (PRINTMSG NO)
03900 (COMPERR NOTONPDL-GETSLOT))
04000 ((NTHCDR (MINUS NO) PDL))))
04100
00100 (DFUNC (ILOC X AC)
00200 (PROG (CNTR BEST BESTNO SL SLOT CNT XCNT)
00300 (COND ((NULL AC) (GO LOOK)))
00400 (COND ((EQUAL X (SLOTCONT AC)) (RETURN AC)))
00500 LOOK (COND ((EQ (CAR X) (QUOTE QUOTE)) (RETURN (LIST X))))
00600 (SETQ SL (SLOTLIST))
00700 (SETQ CNTR 1)
00800 (SETQ BESTNO (ADD1 P2CNT))
00900 (SETQ XCNT (COND ((NUMBERP (CDR X)) (CDR X)) (T P2CNT)))
01000 LOOP (COND ((NULL SL) (GO EXIT)))
01100 (SETQ SLOT (CAR SL))
01200 (COND ((AND SLOT (EQ (CAR SLOT) (CAR X))) (GO ISONE)))
01300 ELOOP(SETQ SL (CDR SL))
01400 (SETQ CNTR (ADD1 CNTR))
01500 (GO LOOP)
01600 EXIT (COND ((NOT (GREATERP BESTNO P2CNT)) (GO RETN)))
01700 (COND ((SPECIALP (CAR X))
01800 (RETURN (LIST (QUOTE SPECIAL) (CAR X)))))
01900 (RETURN NIL)
02000 ISONE(COND ((EQ (CDR SLOT) (QUOTE TAKEN)) (GO ELOOP)))
02100 (SETQ CNT (COND ((NUMBERP (CDR SLOT)) (CDR SLOT)) (T P2CNT)))
02200 (COND ((AND (NOT (LESSP CNT XCNT)) (LESSP CNT BESTNO))
02300 (SETQ BESTNO CNT)
02400 (SETQ BEST CNTR)))
02500 (GO ELOOP)
02600 RETN (RETURN (COND ((NOT (GREATERP BEST NACS)) BEST)
02700 (T (PLUS (MINUS BEST) NACS 1))))))
02800
02900 (DFUNC (ILOC1 X AC)
03000 (PROG (Z)
03100 (COND ((SETQ Z (ILOC X AC)) (RETURN Z)))
03200 (COND ((MEMBER (CAR X) PROGVARS) (RETURN (QUOTE ((QUOTE NIL))))))
03300 (COND ((SETQ Z (ASSOCR (CAR X) VARLIST))
03400 (RETURN (ILOC1 (CONS (CAR Z) (CDR X)) AC))))
03500 (COND ((SETQ Z (ASSOC (CAR X) CCLST))
03600 (RETURN (LOADCARCDR Z
03700 (COND ((NULL AC) (FREEAC))
03800 (T AC))))))
03900 (PRINTMSG (LIST X))
04000 (COMPERR LOSTVAR-ILOC1)))
04100
04200 (DFUNC (INITZ X)
04300 (PROG NIL (SLOTPUSH (LIST X)) (OUTPUSH (QUOTE ((QUOTE NIL))))))
04400
00100 (DFUNC (INTERNALLAMBDA XPR VALAC EFFECTS)
00200 (PROG (LAMXPR LAMARGS SF LAMVARS TL ACL TEM)
00300 (SETQ LAMXPR (CAR XPR))
00400 (SETQ LAMVARS (CADR LAMXPR))
00500 (SETQ LAMARGS (REVERSE (COMPARGS (CDR XPR))))
00600 (COND ((NOT (EQUAL (LENGTH LAMVARS) (LENGTH LAMARGS)))
00700 (USERERR ARGNOERR-INTERNALLAMBDA)))
00800 A (COND ((NULL LAMVARS) (GO B)))
00900 (SETQ TL (ILOC1 (CAR LAMARGS) (FREEAC)))
01000 (REMOVE (CAR LAMARGS))
01100 (COND ((SPECVARP (CAR LAMVARS))
01200 (SETQ SF T)
01300 (COND ((OR (NOT (NUMBERP TL)) (LESSP TL 1))
01400 (LOADARG (SETQ TL (FREEAC)) (CAR LAMARGS)))))
01500 ((OR (NOT (NUMBERP TL)) (DVP (SETQ TEM (SLOTCONT TL))))
01600 (SLOTPUSH TEM)
01700 (COND ((NULL (CDR TEM))
01800 (SETSLOT TL (CONS (CAR TEM) (QUOTE DUP)))))
01900 (OUTPUSH TL)
02000 (SETQ TL 0)))
02100 (SETSLOT TL (CONS (CAR LAMVARS) (QUOTE TAKEN)))
02200 (SETQ ACL (CONS TL ACL))
02300 (SETQ LAMARGS (CDR LAMARGS))
02400 (SETQ LAMVARS (CDR LAMVARS))
02500 (GO A)
02600 B (COND (SF (OUTINST (QUOTE (JSP 6 SPECBIND)))))
02700 (SETQ LAMVARS (CADR LAMXPR))
02800 (SETQ ACL (REVERSE ACL))
02900 C (COND ((NULL LAMVARS) (GO D))
03000 ((SPECVARP (CAR LAMVARS))
03100 (INTLAM1 (CAR LAMVARS) ACS)
03200 (INTLAM1 (CAR LAMVARS) PDL)
03300 (OUTINST (LIST 0
03400 (CAR ACL)
03500 (LIST (QUOTE SPECIAL) (CAR LAMVARS))))))
03600 (RPLACD (SLOTCONT (CAR ACL)) NIL)
03700 (SETQ LAMVARS (CDR LAMVARS))
03800 (SETQ ACL (CDR ACL))
03900 (GO C)
04000 D (SETQ TEM (COMP (CADDR LAMXPR) VALAC))
04100 (COND (SF (OUTINST (QUOTE (PUSHJ P SPECSTR)))))
04200 (INCR P2CNT)
04300 E (COND ((NULL LAMVARS) (RETURN TEM))
04400 ((SPECVARP (CAR LAMVARS)) (INTLAM1 (CAR LAMVARS) ACS)
04500 (INTLAM1 (CAR LAMVARS) PDL)))
04600 (SETQ LAMVARS (CDR LAMVARS))
04700 (GO E)))
04800
00100 (DFUNC (INTLAM1 SPECVAR STORE)
00200 (PROG NIL
00300 A (COND ((NULL STORE) (RETURN NIL))
00400 ((AND (NOT (NULL (CAR STORE)))
00500 (EQ (CAAR STORE) SPECVAR)
00600 (NULL (CDAR STORE)))
00700 (RPLACA STORE NIL)))
00800 (SETQ STORE (CDR STORE))
00900 (GO A)))
01000
01100 (DFUNC (KILLPDL) (RESTORE NIL))
01200
01300 (DFUNC (LAMBDABIND VARS) (BINDVARS VARS T))
01400
01500 (DFUNC (LISTNILS NUMBER)
01600 (PROG (LIST)
01700 LOOP (COND ((ZEROP NUMBER) (RETURN LIST)))
01800 (SETQ LIST (CONS NIL LIST))
01900 (SETQ NUMBER (SUB1 NUMBER))
02000 (GO LOOP)))
02100
00100 (DFUNC (LOADARG ACNO VAR)
00200 (PROG (DATAORG OLDACC DATACONT DAC DOD)
00300 (REMOVE VAR)
00400 (SETQ DATAORG (ILOC1 VAR ACNO))
00500 (SETQ OLDACC (SLOTCONT ACNO))
00600 (SETQ DATACONT (COND ((NUMBERP DATAORG) (SLOTCONT DATAORG))))
00700 (SETQ DAC (DVP OLDACC))
00800 (SETQ DOD (DVP DATACONT))
00900 (COND ((EQ ACNO DATAORG) (COND (DAC (CPUSH ACNO)))
01000 (RETURN NIL)))
01100 (COND ((AND (EQ DATAORG 0)
01200 (NOT DOD)
01300 (NOT DAC)
01400 (GREATERP (PDLDEPTH) MINDEPTH))
01500 (GO POP)))
01600 (COND ((AND (NOT DOD)
01700 (NOT (NULL OLDACC))
01800 (NUMBERP DATAORG)
01900 ~ (GREATERP DATAORG
02000 ~ (DIFFERENCE MINDEPTH (PDLDEPTH)))
02100 (LESSP DATAORG ACNO))
02200 (GO EXCH)))
02300 (COND ((NOT DAC) (GO FREE)))
02400 (GO PUSH)
02500 EXCH (SETSLOT DATAORG OLDACC)
02600 (SETSLOT ACNO DATACONT)
02700 (OUT1 (QUOTE EXCH) ACNO DATAORG)
02800 (RETURN NIL)
02900 PUSH (CPUSH ACNO)
03000 (SETQ DATAORG (LOC VAR))
03100 FREE (COND ((NOT (NUMBERP DATAORG)) (GO MOVE)))
03200 (SETSLOT ACNO
03300 (COND ((NULL (CDR DATACONT))
03400 (CONS (CAR DATACONT) (QUOTE DUP)))
03500 (T DATACONT)))
03600 (OUTMOVE ACNO DATAORG)
03700 (RETURN NIL)
03800 POP (SETSLOT ACNO DATACONT)
03900 (OUTPOP ACNO)
04000 (RETURN NIL)
04100 MOVE (SETSLOT ACNO
04200 (COND ((EQ (CAAR DATAORG) (QUOTE QUOTE)) (CAR DATAORG))
04300 (T (LIST (CAR VAR)))))
04400 (OUTMOVE ACNO DATAORG)
04500 (RETURN NIL)))
04600
00100 (DFUNC (LOADCARCDR ITEM AC)
00200 (PROG (ARG PATH ORIG)
00300 (COND ((EQ (ILOC1 (SETQ ARG (CDDR ITEM)) AC) AC)
00400 (REMOVE ARG)))
00500 (SETQ PATH (CSTEP (CADR ITEM) AC ARG))
00600 (COND ((NULL (CDR PATH))
00700 (SETQ VARLIST (CONS (CONS (CAR (CAR PATH)) (CAR ITEM))
00800 VARLIST))
00900 (REMOVE ARG)
01000 (RETURN (LOC (CAR PATH)))))
01100 (SETQ PATH (REVERSE PATH))
01200 (CPUSH AC)
01300 (SETQ ORIG (LOC (CAR PATH)))
01400 (SETQ PATH (CDR PATH))
01500 (REMOVE ARG)
01600 L1 (COND ((NULL PATH) (GO RET)))
01700 (COND ((NULL (CDR PATH)) (GO L2)))
01800 (COND ((AND (EQ AC VALUEAC) (EQ ORIG VALUEAC))
01900 (OUTCALL 1
02000 (READLIST (CONS (QUOTE C)
02100 (REVERSE (CONS (QUOTE R) PATH)))))
02200 (GO RET)))
02300 L2 (OUT1 (CADR (ASSOC (CAR PATH) (QUOTE ((A HLRZ@) (D HRRZ@)))))
02400 AC
02500 ORIG)
02600 (SETQ PATH (CDR PATH))
02700 (SETQ ORIG AC)
02800 (GO L1)
02900 RET (SETSLOT AC (LIST (CAR ITEM)))
03000 (RETURN AC)))
03100
03200 (DFUNC (LOADCOMP XPR AC) (LOADARG AC (COMP XPR AC)))
03300
03400 (DFUNC (LOADSUBRARGS ARGS)
03500 (PROG (ARGNO)
03600 (SETQ ARGNO (LENGTH ARGS))
03700 LOOP (COND ((NULL ARGS) (RETURN NIL)))
03800 (LOADARG ARGNO (CAR ARGS))
03900 (SETQ ARGS (CDR ARGS))
04000 (SETQ ARGNO (SUB1 ARGNO))
04100 (GO LOOP)))
04200
00100 (DFUNC (LOC X) (ILOC1 X NIL))
00200
00300 (DFUNC (MARKVAL LOCATION)
00400 (PROG (VAR GVAL)
00500 (COND ((NULL LOCATION) (COMPERR NULLLOC-MARKVAL)))
00600 (SETQ GVAL (GENVAL))
00700 (SETQ VAR (CAR (SETSLOT LOCATION (LIST GVAL))))
00800 (SETQ LDLST (CONS VAR LDLST))
00900 (RETURN VAR)))
01000
01100 (DFUNC (NONSPECVARS VRS)
01200 (PROG (ANS)
01300 LOOP (COND ((NULL VRS) (RETURN ANS))
01400 ((SPECVARP (CAR VRS)))
01500 (T (SETQ ANS (CONS (CAR VRS) ANS))))
01600 (SETQ VRS (CDR VRS))
01700 (GO LOOP)))
01800
01900 (DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD)))
02000
02100 (DFUNC (OUTCALL NUM FUN) (OUTFUNCALL (QUOTE CALL) NUM FUN))
02200
02300 (DFUNC (OUTCALLF AC AD) (OUT1 (QUOTE CALLF@) AC AD))
02400
02500 (DFUNC (OUTCJMP FLAG AC ADRESS)
02600 (OUTJMP (COND (FLAG (QUOTE JUMPN)) (T (QUOTE JUMPE))) AC ADRESS))
02700
02800 (DFUNC (OUTENDTAG X)
02900 (COND ((USEDTAGP X) (CLEARITALL) (RST X) (OUTTAG X))))
03000
03100 (DFUNC (OUTFUNCALL TYPE NUM FUN)
03200 (OUTINST (LIST TYPE NUM (LIST (QUOTE E) FUN))))
03300
00100 (DFUNC (OUTGOTAB X)
00200 (PROG (ETAG)
00300 (SETQ ETAG (GENTAG))
00400 (PUTPROP ETAG (TOPCOPY PDL) (QUOTE LEVEL))
00500 (COND ((NOT (EQ (CAAR LASTOUT) (QUOTE JRST))) (OUTJRST ETAG)))
00600 (OUTTAG (CAR X))
00700 LOOP (SETQ X (CDR X))
00800 (COND ((NULL X) (OUTINST (QUOTE (PUSHJ P *UDT)))
00900 (OUTTAG ETAG)
01000 (RETURN NIL)))
01100 (OUTINST (LIST (QUOTE CAIN) GOTABAC (LIST (QUOTE QUOTE) (CAAR X))))
01200 (OUTJRST (CDAR X))
01300 (GO LOOP)))
01400
01500 (DFUNC (OUTJCALL NUM FUN) (OUTFUNCALL (QUOTE JCALL) NUM FUN))
01600
01700 (DFUNC (OUTJMP OP AC ADR)
01800 (PROG NIL
01900 (SAVEACS)
02000 (CLEAR1BOTH)
02100 (RST ADR)
02200 (PUTPROP ADR T (QUOTE USED))
02300 (OUTINST (LIST OP AC ADR))))
02400
02500 (DFUNC (OUTJRST ADR) (OUTJMP (QUOTE JRST) 0 ADR))
02600
02700 (DFUNC (OUTMOVE AC MEM) (OUT1 (QUOTE MOVE) AC MEM))
02800
02900 (DFUNC (OUTMOVEM AC MEM) (OUT1 (QUOTE MOVEM) AC MEM))
03000
03100 (DFUNC (OUTPOP L) (PROG2 (SLOTPOP) (OUT1 (QUOTE POP) (QUOTE P) L)))
03200
03300 (DFUNC (OUTPUSH L) (OUT1 (QUOTE PUSH) (QUOTE P) L))
03400
03500 (DFUNC (OUTPUTSTAT ST)
03600 (PROG (ADD)
03700 (COND ((ATOM ST) (GO PRINT)))
03800 (COND ((EQ (CAR ST) (QUOTE LAP)) (GO PRINT)))
03900 (SETQ CODESIZE (ADD1 CODESIZE))
04000 (SETQ ADD (CADDR ST))
04100 (COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (QUOTE C)))
04200 (SETQ CONSTSIZE (ADD1 CONSTSIZE))))
04300 PRINT(PRINTSTAT ST)))
04400
00100 (DFUNC (OUTSPECPUSH VAR)
00200 (PROG2 (SLOTPUSH (CONS VAR P2CNT))
00300 (OUTPUSH (LIST (QUOTE SPECIAL) VAR))))
00400
00500 (DFUNC (OUTSTAT ST)
00600 (PROG NIL
00700 (COND ((NULL LASTOUT) (GO SETIT)))
00800 (OUTPUTSTAT (CAR LASTOUT))
00900 (MAPC (FUNCTION PRINTEXPR) (CDR LASTOUT))
01000 SETIT(SETQ LASTOUT (CONS ST (LAPNOTES)))
01100 (RETURN NIL)))
01200
01300 (DFUNC (P2*EVAL XPR VALAC EFFECTS)
01400 (PROG (ARG TEM)
01500 (SETQ ARG (CADR XPR))
01600 (COND ((AND (EQ (CAR ARG) (QUOTE CONS))
01700 (EQ (CAADR ARG) (QUOTE QUOTE))
01800 (GETL (SETQ TEM (CADADR ARG))
01900 (QUOTE (FEXPR FSUBR *FSUBR))))
02000 (GO NOCONS)))
02100 (RETURN (CALLSUBR XPR VALAC EFFECTS))
02200 NOCONS
02300 (LOADCOMP (CADDR ARG) VALUEAC)
02400 (PROTECTACS TEM)
02500 (OUTINST (LIST (QUOTE CALL) 17 (LIST (QUOTE E) TEM)))
02600 (RETURN (MARKVAL VALUEAC))))
02700
02800 (DFUNC (P2ARG XPR VALAC EFFECTS)
02900 (PROG (ARG)
03000 (SETQ ARG (COMP (CADR XPR) VALAC))
03100 (COND ((EQ (CAR ARG) (QUOTE QUOTE))
03200 (CPUSH VALAC)
03300 (OUTMOVE VALAC (MINUS (ADD1 (PDLDEPTH))))
03400 (REMOVE ARG)
03500 (OUTINST (LIST (QUOTE HRRZ) VALAC (CADR ARG) VALAC))
03600 (RETURN (MARKVAL VALAC))))
03700 (LOADARG VALAC ARG)
03800 (OUT1 (QUOTE ADD) VALAC (MINUS (ADD1 (PDLDEPTH))))
03900 (OUTINST (LIST (QUOTE HRRZ) VALAC (MINUS INUM0) VALAC))
04000 (RETURN (MARKVAL VALAC))))
04100
00100 (DFUNC (P2BOOL XPR VALAC EFFECTS)
00200 (PROG (CTAG RSL G)
00300 (CLEAR2BOTH)
00400 (PUTPROP (SETQ G (GENTAG)) T (QUOTE SET))
00500 (BOOLEXPR XPR VALAC G T MINDEPTH)
00600 (RETURN (BOOLVALUE VALAC EFFECTS G))))
00700
00800 (DFUNC (P2CARCDR XPR VALAC EFFECTS)
00900 (PROG (TEM)
01000 (COND ((NOT (EQ (LENGTH (CDR XPR)) 1))
01100 (USERERR ARGNOERR-P2CARCDR)))
01200 (COND (EFFECTS (RETURN (COMPE (CADR XPR) VALAC))))
01300 (SETQ XPR (CONS (SETQ TEM (GENSYM))
01400 (CONS (CAR XPR) (COMP (CADR XPR) VALAC))))
01500 (SETQ CCLST (CONS XPR CCLST))
01600 (SETQ TEM (LIST TEM))
01700 (SETQ LDLST (CONS TEM LDLST))
01800 (RETURN TEM)))
01900
02000 (DFUNC (P2COND XPR VALAC EFFECTS)
02100 (PROG (CTAG RSL SETQVARS VARLOC)
02200 (SETQ SETQVARS (CADR XPR))
02300 LOOP (COND ((NULL SETQVARS) (GO CC2)))
02400 (COND ((ASSOC (CAR SETQVARS) LDLST) (GO CC3)))
02500 ELOOP(SETQ SETQVARS (CDR SETQVARS))
02600 (GO LOOP)
02700 CC2 (CLEAR1)
02800 (P2COND1 (CDDR XPR) VALAC EFFECTS MINDEPTH)
02900 (INCR P2CNT)
03000 (INCR P2CNT)
03100 (RETURN (COND (EFFECTS NIL) (T (MARKVAL VALAC))))
03200 CC3 (SETQ VARLOC (LOC (CONS (CAR SETQVARS) P2CNT)))
03300 (COND ((NOT (NUMBERP VARLOC)) (GO CC4)))
03400 (COND ((NOT (DVP (SLOTCONT VARLOC)))
03500 (SETSLOT VARLOC (CONS (CAR SETQVARS) P2CNT))
03600 (GO LOOP)))
03700 CC4 (SLOTPUSH (CONS (CAR SETQVARS) P2CNT))
03800 (OUTPUSH VARLOC)
03900 (GO ELOOP)))
04000
00100 (DFUNC (P2COND1 EXP VALAC EFFECTS MINDEPTH)
00200 (PROG (CONDEXIT PAIREXIT H1 H2 RETNIL IRSSL ACNIL PAIR ATAG REST AC)
00300 (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
00400 (SETQ CONDEXIT (GENTAG))
00500 (SETQ IRSSL (TOPCOPY PDL))
00600 (SETQ MINDEPTH (PDLDEPTH))
00700 (PUTPROP CONDEXIT IRSSL (QUOTE LEVEL))
00800 LOOP (SETQ RSL NIL)
00900 (COND ((NULL EXP) (COND (RETNIL (LOADARG AC (QUOTE (QUOTE NIL)))))
01000 (OUTENDTAG CONDEXIT)
01100 (COND ((USEDTAGP PAIREXIT) (CLEARITALL)))
01200 (RESTORE IRSSL)
01300 (RETURN NIL)))
01400 (SETQ PAIR (CAR EXP))
01500 (COND ((NULL (CDR PAIR))
01600 (LOADCOMP (CAR PAIR) AC)
01700 (COND ((NOT (NULL (CDR EXP))) (OUTCJMP T AC CONDEXIT))
01800 (T (RESTORE IRSSL)))
01900 (GO NONIL)))
02000 (COND ((AND (EQUAL (CDR PAIR) (QUOTE ((QUOTE NIL))))
02100 (EQ (CAAR PAIR) (QUOTE NULL))
02200 (OR (ATOM (CADAR PAIR))
02300 (NOT (HASPROP (CAADAR PAIR) (QUOTE BOOL)))))
02400 (LOADCOMP (CADAR PAIR) AC)
02500 (OUTCJMP NIL AC CONDEXIT)
02600 (SETQ RETNIL T)
02700 (GO ELOOP)))
02800 (COND ((OR LDLST (NOT (NULL (CDDR PAIR)))) (GO L2)))
02900 (COND ((AND (EQ (CAADR PAIR) (QUOTE GO))
03000 (ATOM (SETQ ATAG (CADADR PAIR))))
03100 (BOOLEXPR (CAR PAIR) AC (EQUIVTAG ATAG) T MINDEPTH)
03200 (GO NONIL)))
03300 (COND ((EQUAL (CADR PAIR) (QUOTE (RETURN (QUOTE NIL))))
03400 (BOOLEXPR (CAR PAIR) AC EXITN T MINDEPTH)
03500 (GO NONIL)))
03600 L2 (SETQ PAIREXIT (SETQ CTAG (GENTAG)))
03700 (PUTPROP PAIREXIT IRSSL (QUOTE LEVEL))
03800 (SETQ RSL NIL)
03900 (BOOLEXPR (CAR PAIR) AC PAIREXIT NIL MINDEPTH)
04000 (SETQ H2 (COND ((NOT (ATOM RSL)) RSL)
04100 (T (LIST (TOPCOPY ACS)
04200 (TOPCOPY PDL)
04300 (PDLDEPTH)))))
04400 (SETQ H1 (LIST (TOPCOPY SPLDLST) (TOPCOPY CCLST)))
04500 (SETQ REST (CDR PAIR))
04600 LP1 (COND ((NULL (CDR REST)) (GO L1)))
04700 (COMPE (CAR REST) AC)
04800 (SETQ REST (CDR REST))
04900 (GO LP1)
05000 L1 (COND (EFFECTS (COMPE (CAR REST) AC))
05100 (T (LOADCOMP (CAR REST) AC)))
05200 (SAVEACS)
05300 (SETQ SPLDLST (CAR H1))
05400 (SETQ CCLST (CADR H1))
05500 (SETQ H1 ACS)
05600 (SETQ ACS (CAR H2))
05700 (SETQ ACNIL (EQUAL (SLOTCONT AC) (QUOTE (QUOTE NIL))))
05800 (SETQ ACS H1)
05900 (SETQ RETNIL NIL)
06000 (COND ((NOT (MEMQ (CAAR REST) (QUOTE (GO RETURN))))
06100 (COND ((OR (NOT (NULL (CDR EXP)))
06200 (AND (NOT EFFECTS)
06300 (NOT ACNIL)
06400 (SETQ RETNIL (USEDTAGP PAIREXIT))))
06500 (OUTJRST CONDEXIT))
06600 (T (RESTORE IRSSL)))))
06700 (SETQ ACS (CAR H2))
06800 (SETQ PDL (CADR H2))
06900 (SETQ PDLDEPTH (CADDR H2))
07000 (OUTTAG PAIREXIT)
07100 (GO ELOOP)
07200 NONIL(SETQ RETNIL NIL)
07300 ELOOP(SETQ EXP (CDR EXP))
07400 (GO LOOP)))
07500
00100 (DFUNC (P2ELSE XPR VALAC EFFECTS) (COMPERR SOMETHINGELSE-P2ELSE))
00200
00300 (DFUNC (P2EQ XPR VALAC EFFECTS)
00400 (PROG NIL
00500 (COND (EFFECTS (COMPE (CADR XPR) VALAC)
00600 (COMPE (CADDR XPR) VALAC)
00700 (RETURN NIL)))
00800 (BOOLEQ1 (CDR XPR) VALAC NIL NIL)
00900 (RETURN (BOOLVALUE VALAC EFFECTS NIL))))
01000
01100 (DFUNC (P2GO XPR VALAC EFFECTS)
01200 (PROG (TAG)
01300 (SETQ TAG (CADR XPR))
01400 (SAVEACS)
01500 (CLRPVARS)
01600 (COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG)))
01700 (T (LOADARG GOTABAC (COMP TAG VALAC)) (OUTJRST VGO)))
01800 (RETURN (MARKVAL VALUEAC))))
01900
00100 (DFUNC (P2PROG XPR VALAC EFFECTS)
00200 (PROG (PSFLG)
00300 (SETQ PSFLG (PROGBIND (CADDR XPR)))
00400 (SETQ PRGSPFLG NIL)
00500 (CLEAR1)
00600 (P2PROG1 XPR VALAC EFFECTS MINDEPTH)
00700 (COND (PSFLG (OUTINST (QUOTE (PUSHJ P SPECSTR)))))
00800 (RETURN (MARKVAL VALAC))))
00900
01000 (DFUNC (P2PROG1 XPR VALAC EFFECTS MINDEPTH)
01100 (PROG (GOLIST EXIT EXITN PVR PRSSL PROGSW VGO)
01200 (INCR P2CNT)
01300 (SETQ PROGSW T)
01400 (SETQ PVR VALAC)
01500 (SETQ EXIT (GENTAG))
01600 (SETQ EXITN (GENTAG))
01700 (SETQ VGO (GENTAG))
01800 (SETQ GOLIST (CONS (CONS NIL EXIT)
01900 (CONS (CONS NIL EXITN)
02000 (CONS (CONS NIL VGO) (CADR XPR)))))
02100 (SETQ PROGVARS (NONSPECVARS (CADDR XPR)))
02200 (SETQ XPR (CDDDR XPR))
02300 LOOP (COND ((NULL XPR) (GO EXITN)))
02400 (INCR P2CNT)
02500 (COND ((NOT PROGSW) (RESTORE PRSSL)))
02600 (COND ((TAGP (CAR XPR)) (PROGTAG (CAR XPR)))
02700 ((AND (NULL (CDR XPR)) (EQ (CAAR XPR) (QUOTE RETURN)))
02800 (COND ((EQUAL (CDAR XPR) (QUOTE ((QUOTE NIL)))) (GO EXITN))
02900 (T (LOADARG PVR (COMP (CADAR XPR) VALAC))
03000 (COND ((USEDTAGP EXITN) (OUTJRST EXIT)
03100 (GO EXITN))
03200 (T (GO EXIT))))))
03300 (T (COMPE (CAR XPR) VALAC)))
03400 (SETQ XPR (CDR XPR))
03500 (GO LOOP)
03600 EXITN(OUTENDTAG EXITN)
03700 (COND ((NOT (EQ (CAAR LASTOUT) (QUOTE JRST)))
03800 (LOADARG PVR (QUOTE (QUOTE NIL)))))
03900 EXIT (OUTENDTAG EXIT)
04000 (INCR P2CNT)
04100 (INCR P2CNT)
04200 (COND ((USEDTAGP VGO) (OUTGOTAB (CONS VGO (CDDDR GOLIST)))))
04300 (RETURN NIL)))
04400
00100 (DFUNC (P2PROG2 XPR VALAC EFFECTS)
00200 (PROG (ARGS ARG2)
00300 (SETQ ARGS (CDR XPR))
00400 (COND ((LESSP (LENGTH ARGS) 2) (USERERR TOFEWARGS-P2PROG2)))
00500 (COMPE (CAR ARGS) VALAC)
00600 (SETQ ARG2 (COND ((NOT EFFECTS) (COMP (CADR ARGS) VALAC))
00700 (T (COMPE (CADR ARGS) VALAC))))
00800 (SETQ ARGS (CDDR ARGS))
00900 LOOP (COND ((NULL ARGS) (RETURN ARG2)))
01000 (COMPE (CAR ARGS) VALAC)
01100 (SETQ ARGS (CDR ARGS))
01200 (GO LOOP)))
01300
01400 (DFUNC (P2QUOTE XPR VALAC EFFECTS) XPR)
01500
01600 (DFUNC (P2RETURN XPR VALAC EFFECTS)
01700 (PROG (VAL)
01800 (SETQ VAL (CADR XPR))
01900 (SAVEACS)
02000 (CLRPVARS)
02100 (COND ((EQUAL VAL (QUOTE (QUOTE NIL))) (OUTJRST EXITN))
02200 (T (LOADARG PVR (COMP VAL VALAC)) (OUTJRST EXIT)))
02300 (RETURN (COND (EFFECTS NIL) (T (MARKVAL VALAC))))))
02400
02500 (DFUNC (P2RPLAC XPR VALAC EFFECTS)
02600 (PROG (ARG1 ARG2)
02700 (SETQ ARG1 (COMP (CADR XPR) (FREEAC)))
02800 (SETQ ARG2 (COMP (CADDR XPR) (FREEAC)))
02900 (ILOC1 ARG1 VALAC)
03000 (LOC ARG2)
03100 (REMOVS ARG1)
03200 (REMOVS ARG2)
03300 (CLEAR2BOTH)
03400 (COND ((EQUAL ARG2 (QUOTE (QUOTE NIL)))
03500 (OUT1 (CADR (ASSOC (CAR XPR)
03600 (QUOTE ((RPLACA HRRZS@)
03700 (RPLACD HLLZS@)))))
03800 0
03900 (LOC ARG1)))
04000 (T (OUT1 (CADR (ASSOC (CAR XPR)
04100 (QUOTE ((RPLACA HRLM@)
04200 (RPLACD HRRM@)))))
04300 (PUTINAC ARG2 (FREEAC))
04400 (LOC ARG1))))
04500 (REMOVE ARG2)
04600 (RETURN ARG1)))
04700
00100 (DFUNC (P2SETARG XPR VALAC EFFECTS)
00200 (PROG (TEM)
00300 (LOC (SETQ TEM (COMP (CADDR XPR) VALAC)))
00400 (COND ((EQ (CAADR XPR) (QUOTE QUOTE))
00500 (OUT1 (QUOTE MOVE) 2 (MINUS (ADD1 (PDLDEPTH))))
00600 (RETURN (OUTINST (LIST (QUOTE HRRM)
00700 (PUTINAC TEM VALAC)
00800 (CADADR XPR)
00900 2)))))
01000 (LOADCOMP (CADR XPR) 2)
01100 (CLEARACS)
01200 (OUT1 (QUOTE ADD) 2 (MINUS (ADD1 (PDLDEPTH))))
01300 (OUTINST (LIST (QUOTE HRRM)
01400 (PUTINAC TEM VALAC)
01500 (MINUS INUM0)
01600 2))))
01700
00100 (DFUNC (P2SETQ XPR VALAC EFFECTS)
00200 (PROG (NVAR VALLOC HOME VAR VAL TEM AC)
00300 (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
00400 (SETQ VAR (CAR (CDR XPR)))
00500 (SETQ VAL (COMP (CADR (CDR XPR)) AC))
00600 (ILOC1 VAL AC)
00700 (COND ((ASSOC VAR SPLDLST) (OUTSPECPUSH VAR) (REMSPVAR VAR)))
00800 (REMOVE VAL)
00900 (FREEZE VAR)
01000 (SETQ VALLOC (LOC VAL))
01100 (SETQ HOME (COND ((SPECVARP VAR) T)
01200 ((NOT (ILOC (SETQ NVAR (CONS VAR P2CNT)) AC))
01300 NIL)
01400 (T (NOT (DVP (SLOTCONT (LOC NVAR)))))))
01500 (INCR P2CNT)
01600 (COND ((AND EFFECTS (NOT HOME))
01700 (COND ((AND (NUMBERP VALLOC)
01800 (NOT (DVP (SLOTCONT VALLOC))))
01900 (SETSLOT VALLOC (LIST VAR))
02000 (GO EXIT))
02100 (T (SLOTPUSH (LIST VAR))
02200 (OUTPUSH VALLOC)
02300 (GO EXIT)))))
02400 (COND ((AND HOME (EQUAL VAL (QUOTE (QUOTE NIL))))
02500 (SETQ TEM T)
02600 (OUT1 (COND ((OR EFFECTS (DVP (SLOTCONT AC)))
02700 (SETQ TEM NIL)
02800 (QUOTE CLEARM))
02900 (T (QUOTE CLEARB)))
03000 AC
03100 (SETQ VAL (COND ((SPECVARP VAR)
03200 (LIST (QUOTE SPECIAL) VAR))
03300 (T (ILOC (CONS VAR (SUB1 P2CNT))
03400 AC)))))
03500 (COND ((NUMBERP VAL) (SETSLOT VAL (LIST VAR))))
03600 (COND (TEM (SETSLOT AC
03700 (CONS VAR
03800 (COND ((NUMBERP VAL) (QUOTE DUP))
03900 (T NIL))))))
04000 (GO EXIT)))
04100 (COND ((OR (NOT (NUMBERP VALLOC))
04200 (LESSP VALLOC 0)
04300 (DVP (SLOTCONT VALLOC)))
04400 (LOADARG AC VAL)
04500 (SETQ VALLOC AC)))
04600 (SETSLOT VALLOC (LIST VAR))
04700 (COND ((SPECVARP VAR)
04800 (COND ((ZEROP VALLOC) (OUTPOP (LIST (QUOTE SPECIAL) VAR)))
04900 (T (OUTMOVEM VALLOC (LIST (QUOTE SPECIAL) VAR))))))
05000 EXIT (RETURN (COMP VAR AC))))
05100
00100 (DFUNC (P2STORE XPR VALAC EFFECTS)
00200 (PROG (TEM)
00300 (LOC (SETQ TEM (COMP (CADDR XPR) VALAC)))
00400 (COMPE (CADR XPR) VALAC)
00500 (LOADARG ARRAYAC TEM)
00600 (OUTINST (QUOTE (PUSHJ P NSTR)))
00700 (RETURN TEM)))
00800
00900 (DFUNC (PASS2 X)
01000 (PROG (ACS PDL PDLDEPTH MINDEPTH LDLST SPLDLST SPECFLAG PRGSPFLG
01100 CCLST VARLIST PROGVARS PROGSW GOLIST)
01200 (SETQ P2CNT 1)
01300 (SETQ ACS (LISTNILS NACS))
01400 (SETQ ALLACS (SUB1 (LSH 1 NACS)))
01500 (SETQ PDL NIL)
01600 (SETQ PDLDEPTH (LENGTH PDL))
01700 (SETQ MINDEPTH (PDLDEPTH))
01800 (SETQ SPECFLAG (LAMBDABIND (CADR X)))
01900 (COND ((NOT (EQ (CAADDR X) (QUOTE PROG))) (SETQ PRGSPFLG NIL)))
02000 (LOADCOMP (CADDR X) VALUEAC)
02100 (EXITBUM SPECFLAG)
02200 (OUTINST (OUTINST NIL))
02300 (COND (LDLST (COMPERR LDLSTLEFT-PASS2)))
02400 (RETURN NIL)))
02500
02600 (DFUNC (PROGBIND VARS) (BINDVARS VARS NIL))
02700
02800 (DFUNC (PROGTAG TAG)
02900 (PROG NIL
03000 (CLEAR2BOTH)
03100 (CLEARACS)
03200 (CLRPVARS)
03300 (RESTORE PRSSL)
03400 (OUTTAG (EQUIVTAG TAG))))
03500
03600 (DFUNC (PROTECTACS X)
03700 (PROG (WHICHACS ACNO)
03800 (SETQ WHICHACS (ACEFFECTS X))
03900 (SETQ ACNO 0)
04000 LOOP (SETQ ACNO (ADD1 ACNO))
04100 (COND ((ZEROP WHICHACS) (RETURN NIL))
04200 ((NOT (ZEROP (BOOLE 1 1 WHICHACS))) (CLEARAC ACNO)))
04300 (SETQ WHICHACS (LSH WHICHACS -1))
04400 (GO LOOP)))
04500
00100 (DFUNC (PUTINAC X AC)
00200 (PROG (Z)
00300 (SETQ Z (LOC X))
00400 (COND ((NOT (ACNUMP Z)) (LOADARG (SETQ Z AC) X)))
00500 (REMOVE X)
00600 (CPUSH Z)
00700 (RETURN Z)))
00800
00900 (DFUNC (REMOVE DATA)
01000 (PROG NIL (REMLST DATA (QUOTE LDLST)) (REMLST DATA (QUOTE SPLDLST))))
01100
01200 (DFUNC (REMLST DATA LST)
01300 (PROG (TEM)
01400 (SETQ TEM (GETPROP LST (QUOTE VALUE)))
01500 LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
01600 (COND ((EQUAL (CADR TEM) DATA) (RPLACD TEM (CDDR TEM)))
01700 (T (SETQ TEM (CDR TEM))))
01800 (GO LOOP)))
01900
02000 (DFUNC (REMOVS DATA) (REMLST DATA (QUOTE SPLDLST)))
02100
02200 (DFUNC (REMSPVAR SPV)
02300 (PROG (SPL)
02400 (SETQ SPL (GETPROP (QUOTE SPLDLST) (QUOTE VALUE)))
02500 BACK (COND ((NULL (CDR SPL)) (RETURN NIL)))
02600 (COND ((EQ SPV (CAADR SPL)) (RPLACD SPL (CDDR SPL)))
02700 (T (SETQ SPL (CDR SPL))))
02800 (GO BACK)))
02900
00100 (DFUNC (RESTORE OLDPDL)
00200 (PROG (C V R TEM OLDDEPTH DEPTHDIF)
00300 (SETQ OLDDEPTH (LENGTH OLDPDL))
00400 (COND ((GREATERP OLDDEPTH (PDLDEPTH))
00500 (PRINTMSG (LIST OLDPDL PDL))
00600 (COMPERR PDLSHORT-RESTORE)))
00700 A1 (SETQ C 0)
00800 A (COND ((EQUAL OLDDEPTH (PDLDEPTH)) (RETURN (SHRINKPDL C)))
00900 ((DVP (SETQ R (CAR PDL))) (GO CPP)))
01000 (SETQ C (ADD1 C))
01100 (SLOTPOP)
01200 (GO A)
01300 CPP (SHRINKPDL C)
01400 CPP1 (SETQ V OLDPDL)
01500 (SETQ C 0)
01600 (SETQ DEPTHDIF (*DIF (PDLDEPTH) OLDDEPTH))
01700 CPP3 (COND ((NULL V) (SETQ V (FINDFREEAC))
01800 (COND ((NULL V) (COMPERR NOAC-RESTORE)))
01900 (SETSLOT V R)
02000 (OUTPOP V)
02100 (GO A1))
02200 ((AND (CAR V)
02300 (EQ (CAAR V) (CAR R))
02400 (NOT (DVP (SLOTCONT (SETQ TEM
02500 (MINUS (PLUS C
02600 DEPTHDIF)))))))
02700 (GO CPP2)))
02800 (SETQ C (ADD1 C))
02900 (SETQ V (CDR V))
03000 (GO CPP3)
03100 CPP2 (SETSLOT TEM R)
03200 (OUTPOP TEM)
03300 (GO A1)))
03400
03500 (DFUNC (RSLSET X)
03600 (COND ((EQ X CTAG)
03700 (SETQ RSL (COND ((AND RSL
03800 (NOT (AND (EQUAL (CAR RSL) ACS)
03900 (EQUAL (CADR RSL) PDL))))
04000 (QUOTE LOSE))
04100 (T (LIST (TOPCOPY ACS)
04200 (TOPCOPY PDL)
04300 (PDLDEPTH))))))))
04400
00100 (DFUNC (RST TAG)
00200 (COND ((NULL TAG) NIL)
00300 ((ASSOCR TAG GOLIST) (RESTORE PRSSL))
00400 ((REMPROP TAG (QUOTE SET)) (SAVEACS)
00500 (PUTPROP TAG (TOPCOPY PDL) (QUOTE LEVEL))
00600 (SETQ MINDEPTH (PDLDEPTH)))
00700 ((SETQ TAG (SEEKPROP TAG (QUOTE LEVEL))) (RESTORE (CADR TAG)))
00800 (T (COMPERR NIL-RST))))
00900
01000 (DFUNC (SAVEACS)
01100 (PROG (K)
01200 (SETQ K 0)
01300 LOOP (COND ((EQ K NACS) (RETURN NIL)))
01400 (CPUSH (SETQ K (ADD1 K)))
01500 (GO LOOP)))
01600
01700 (DFUNC (SETSLOT X Y) (RPLACA (GETSLOT X) Y))
01800
01900 (DFUNC (SHRINKPDL C)
02000 (COND ((NOT (ZEROP C))
02100 (OUTINST (LIST (QUOTE SUB) (QUOTE P) (GENCONST 0 0 C C 0))))))
02200
02300 (DFUNC (SIDEEFFECTS FUN) (NOT (HASPROP FUN (QUOTE ACS))))
02400
02500 (DFUNC (SLOTCONT X) (CAR (GETSLOT X)))
02600
02700 (DFUNC (SLOTLIST) (APPEND ACS PDL))
02800
02900 (DFUNC (SLOTPOP)
03000 (PROG NIL (SETQ PDLDEPTH (SUB1 PDLDEPTH)) (SETQ PDL (CDR PDL))))
03100
03200 (DFUNC (SLOTPUSH SC)
03300 (PROG NIL (SETQ PDLDEPTH (ADD1 PDLDEPTH)) (SETQ PDL (CONS SC PDL))))
03400
03500 (DFUNC (SPECVARP VAR) (MEMBER VAR SPECVARS))
03600
03700 (DFUNC (TRANSOUT OP AC AD)
03800 (PROG (TEM IND)
03900 (COND ((OR (ATOM AD) (ATOM (CAR AD))) (GO DONE)))
04000 (SETQ AD (CAR AD))
04100 (COND ((SETQ TEM (SEEKPROP OP (QUOTE IMMED)))
04200 (SETQ OP (CADR TEM))
04300 (GO DONE)))
04400 (SETQ AD (GENCONST 0 0 AD 0 0))
04500 DONE (SETQ IND (COND ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL)
04600 (T (LIST (QUOTE P)))))
04700 (RETURN (MCONS OP AC AD IND))))
04800
04900 (DFUNC (USEDTAGP TAG) (HASPROP TAG (QUOTE USED)))
05000
00100 (MAPDEF PASS2 (EXPR CALLSUBR) (SUBR CALLSUBR) (*SUBR CALLSUBR)
00200 (*UNDEF CALLSUBR) (LSUBR CALLLSUBR) (*LSUBR CALLLSUBR)
00300 (FEXPR CALLFSUBR) (FSUBR CALLFSUBR) (*FSUBR CALLFSUBR)
00400 (FUNVAR CALLFUNARGS) (CARCDR P2CARCDR) (P2 DOP2))
00500
00600 (MAPDEF P2 (AND P2BOOL) (ARG P2ARG) (*EVAL P2*EVAL) (COND P2COND)
00700 (EQ P2EQ) (GO P2GO) (NULL P2BOOL) (OR P2BOOL)
00800 (QUOTE P2QUOTE) (PROG P2PROG) (PROG2 P2PROG2)
00900 (RETURN P2RETURN) (RPLACA P2RPLAC) (RPLACD P2RPLAC)
01000 (SETARG P2SETARG) (SETQ P2SETQ) (STORE P2STORE))
01100
01200 (MAPDEF BOOL (AND BOOLAND) (EQ BOOLEQ) (NULL BOOLNULL) (OR BOOLOR)
01300 (QUOTE BOOLQUOTE))
01400
01500 (SETQ CARCDRDEPTH 4)
01600
01700 (PROG (BASE COUNT LIMIT MIDDLE NAME)
01800 (SETQ BASE 2)
01900 (SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH))))
02000 (SETQ COUNT (LSH 1 1))
02100 LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL)))
02200 (SETQ MIDDLE (SUBST (QUOTE A)
02300 0
02400 (SUBST (QUOTE D) 1 (CDR (EXPLODE COUNT)))))
02500 (SETQ NAME (READLIST (APPEND (QUOTE (C)) MIDDLE (QUOTE (R)))))
02600 (PUTPROP NAME
02700 (CONS (CAR MIDDLE)
02800 (COND ((CDR MIDDLE)
02900 (READLIST (APPEND (QUOTE (C))
03000 (CDR MIDDLE)
03100 (QUOTE (R)))))))
03200 (QUOTE CARCDR))
03300 (SETQ COUNT (ADD1 COUNT))
03400 (GO LOOP))
03500
03600 (MAPDEF ACS (*APPEND 37) (ATOM 1) (CONS 3) (GENSYM 7) (GET 1)
03700 (LAST 3) (LENGTH 7) (MEMBER 37) (NCONS 3) (XCONS 3))
03800
03900 (MAPDEF COMMU (CONS XCONS) (EQUAL EQUAL) (*GREAT *LESS)
04000 (*LESS *GREAT) (*PLUS *PLUS) (*TIMES *TIMES))
04100
00100 (MAPDEF IMMED (CAME CAIE) (CAMN CAIN) (HLLZS@ HLLZS) (HLRZ@ HLRZ)
00200 (HRLM@ HRLM) (HRRM@ HRRM) (HRRZ@ HRRZ) (HRRZS@ HRRZS)
00300 (MOVE MOVEI))
00400
00500 (SETQ NACS 5)
00600
00700 (SETQ VALUEAC 1)
00800
00900 (SETQ FARGAC 1)
01000
01100 (SETQ GOTABAC 1)
01200
01300 (SETQ ARRAYAC 1)
01400
01500 (SETQ INUM0 (MAKNUM 0 (QUOTE FIXNUM)))
01600
01700 (ENDBLOCK PASS2)
01800
01900 (BEGINBLOCK DEBUG)
02000
02100 (DFUNC (CMPBREAK TYPE MESSAGE)
02200 (PROG NIL
02300 (INC NIL T)
02400 (OUTC NIL T)
02500 (COND ((ATMARGIN) (LINEF 1)) (T (LINEF 2)))
02600 (PRINL (APPEND TYPE MESSAGE))
02700 (LINEF 1)
02800 LOOP (COND ((EQUAL (ERRSET (EVALREAD)) (QUOTE (PROCEED)))
02900 (RETURN (QUOTE DONE))))
03000 (GO LOOP)))
03100
03200 (DEFPROP COMPERR
03300 (LAMBDA (L) (CMPBREAK (QUOTE (*COMPILER ERROR*)) L))
03400 FEXPR)
03500
03600 (DFUNC (EVALREAD)
03700 (PROG (EX)
03800 (LINEF 1)
03900 (SETQ EX (READ))
04000 (PRINC *SP)
04100 (RETURN (PRINC (EVAL EX)))))
04200
04300 (DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST)))
04400
04500 (DEFPROP USERERR (LAMBDA (L) (CMPBREAK (QUOTE (*USER ERROR*)) L)) FEXPR)
04600
04700 (SETQ TRACELIST NIL)
04800
04900 (ENDBLOCK DEBUG)
05000
05100 (BEGINBLOCK IO)
05200
00100 (DFUNC (ATMARGIN) (EQ (CHRCT) (LINELENGTH NIL)))
00200
00300 (DFUNC (CARRETN) (COND ((NOT (ATMARGIN)) (LINEF 1))))
00400
00500 (DFUNC (FORMF) (PROG NIL (PRINC *FF) (SETQ LINCNT PAGEHEIGHT)))
00600
00700 (DFUNC (LINEF N)
00800 (PROG NIL
00900 LOOP (COND ((ZEROP N) (RETURN NIL)))
01000 (TERPRI)
01100 (SETQ N (SUB1 N))
01200 (GO LOOP)))
01300
01400 (DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L))
01500
01600 (DFUNC (PRINS FN)
01700 (PROG2 (COND ((GREATERP (ADD1 (FLATSIZE FN)) (CHRCT)) (LINEF 1)))
01800 (PRINTEXPR FN)))
01900
02000 (DFUNC (PRINTEXPR XPR) (PROG2 (PRIN1 XPR) (PRINC *SP)))
02100
02200 (DFUNC (PRINTSTAT STAT)
02300 (PROG NIL
02400 (COND ((GREATERP (DIFFERENCE (LINELENGTH NIL) (CHRCT)) 7)
02500 (LINEF 1)))
02600 (COND ((NULL STAT) (GO WORD))
02700 ((ATOM STAT) (GO TAG))
02800 ((EQ (CAR STAT) (QUOTE LAP)) (GO TAG)))
02900 WORD (PRINC *TB)
03000 (PRINTEXPR STAT)
03100 (RETURN NIL)
03200 TAG (CARRETN)
03300 (PRINTEXPR STAT)
03400 (RETURN NIL)))
03500
00100 (MAPCAR (FUNCTION (LAMBDA (PAIR)
00200 (PROG2 (SET (CAR PAIR)
00300 (INTERN (ASCII (CADR PAIR))))
00400 (CAR PAIR))))
00500 (QUOTE ((*SP 40) (*TB 11)
00600 (*CR 15)
00700 (*LF 12)
00800 (*VT 13)
00900 (*FF 14)
01000 (*CO 54)
01100 (*PT 56)
01200 (*LP 50)
01300 (*RP 51)
01400 (*SL 57)
01500 (*AM 33)
01600 (*AT 100)
01700 (*RO 177)
01800 (*COLON 72))))
01900
02000 (SETQ LINCNT 0)
02100
02200 (SETQ PAGEHEIGHT 74)
02300
02400 (SETQ PAGEWIDTH 120)
02500
02600 (ENDBLOCK IO)
02700
02800 (BEGINBLOCK GENERAL)
02900
03000 (DFUNC (ADDTOLIST X Y) (COND ((MEMBER X Y) Y) (T (CONS X Y))))
03100
03200 (DFUNC (ASSOCR X Y)
03300 (PROG NIL
03400 LOOP (COND ((NULL Y) (RETURN NIL))
03500 ((EQ X (CDAR Y)) (RETURN (CAR Y))))
03600 (SETQ Y (CDR Y))
03700 (GO LOOP)))
03800
03900 (DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMBER XPR (QUOTE (T NIL)))))
04000
04100 (DFUNC (COPY EX) (SUBST 0 0 EX))
04200
04300 (DFUNC (DEINITSYM NAME) (DELETEPROP NAME (QUOTE SYMNO)))
04400
04500 (DFUNC (FSUBRP FUN) (GETL FUN (QUOTE (FEXPR *FSUBR FSUBR))))
04600
00100 (DFUNC (GETGET ATOM PROP)
00200 (PROG (TEM PTAB)
00300 (SETQ PTAB (FIRSTPROP ATOM))
00400 LOOP (COND ((LASTPROP PTAB) (RETURN NIL)))
00500 (COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP))
00600 (RETURN TEM)))
00700 (SETQ PTAB (NEXTPROP PTAB))
00800 (GO LOOP)))
00900
01000 (DFUNC (INITSYM NAME) (INITPROP NAME (QUOTE SYMNO) 1))
01100
01200 (DFUNC (LSUBRP FUN) (GETL FUN (QUOTE (LSUBR *LSUBR))))
01300
01400 (DFUNC (MAKESPECIAL VAR)
01500 (PROG NIL
01600 (COND ((HASPROP VAR (QUOTE LOCAL))
01700 (PRINTMSG (CONS VAR (QUOTE (LOCAL AND SPECIAL))))))
01800 (SETPROP VAR (QUOTE SPECIAL) T)
01900 (RETURN VAR)))
02000
02100 (DFUNC (MAKESYM IDENT NUMBER)
02200 (PROG (*NOPOINT)
02300 (SETQ *NOPOINT T)
02400 (RETURN (MAKNAM (APPEND (EXPLODE IDENT) (EXPLODE NUMBER))))))
02500
02600 (DFUNC (MAKEUNSPECIAL VAR) (COND ((REMPROP VAR (QUOTE SPECIAL)) VAR)))
02700
02800 (DFUNC (NEXTSYM NAME)
02900 (PROG (NUM)
03000 (SETQ NUM (GETPROP NAME (QUOTE SYMNO)))
03100 (PUTPROP NAME (ADD1 NUM) (QUOTE SYMNO))
03200 (RETURN (MAKESYM NAME NUM))))
03300
03400 (DFUNC (NTHCDR NUM EXP)
03500 (PROG NIL
03600 (COND ((MINUSP NUM) (COMPERR NEGNUM-NTHCDR)))
03700 LOOP (COND ((ZEROP NUM) (RETURN EXP)))
03800 (COND ((ATOM EXP) (COMPERR ATOM-NTHCDR)))
03900 (SETQ EXP (CDR EXP))
04000 (SETQ NUM (SUB1 NUM))
04100 (GO LOOP)))
04200
04300 (DFUNC (SUBRP FUN) (GETL FUN (QUOTE (EXPR SUBR ARRAY *SUBR *UNDEF))))
04400
04500 (DFUNC (TOPCOPY SXP) (APPEND SXP NIL))
04600
04700 (BEGINBLOCK PROPTABLE)
04800
00100 (DFUNC (DELETEPROP IDENT PROPNAM)
00200 (PROG (TEM)
00300 (SETQ TEM IDENT)
00400 LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
00500 (COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
00600 (RETURN T)))
00700 (SETQ TEM (CDDR TEM))
00800 (GO LOOP)))
00900
01000 (DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))
01100
01200 (DFUNC (INITPROP IDENT PROPNAM PROPVAL)
01300 (RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))
01400
01500 (DFUNC (SEEKPROP IDENT PROPNAM)
01600 (PROG (TEM)
01700 (SETQ TEM (GETL IDENT (LIST PROPNAM)))
01800 (COND ((NULL TEM) (RETURN NIL)))
01900 (RETURN TEM)))
02000
02100 (DFUNC (SETPROP IDENT PROPNAM PROPVAL)
02200 (PUTPROP IDENT PROPVAL PROPNAM))
02300
02400 (ENDBLOCK PROPTABLE)
02500
02600 (ENDBLOCK GENERAL)
02700
02800 (ENDBLOCK COMPILER)
02900